-- | Common music notation dynamic marks. module Music.Theory.Dynamic_Mark where import Data.Char {- base -} import Data.List {- base -} import Data.Maybe {- base -} import Text.Read {- base -} import qualified Music.Theory.List as T {- hmt -} -- | Enumeration of dynamic mark symbols. data Dynamic_Mark = Niente | Ppppp | Pppp | Ppp | Pp | P | Mp | Mf | F | Ff | Fff | Ffff | Fffff | Fp | Sf | Sfp | Sfpp | Sfz | Sffz deriving (Eq,Ord,Enum,Bounded,Show,Read) {- | Case insensitive reader for 'Dynamic_Mark'. > map dynamic_mark_t_parse_ci (words "pP p Mp F") -} dynamic_mark_t_parse_ci :: String -> Maybe Dynamic_Mark dynamic_mark_t_parse_ci = let capitalise x = toUpper (head x) : map toLower (tail x) in readMaybe . capitalise {- | Lookup Midi velocity for 'Dynamic_Mark'. The range is linear in @0-127@. > let r = [0,6,17,28,39,50,61,72,83,94,105,116,127] > mapMaybe dynamic_mark_midi [Niente .. Fffff] == r > mapMaybe dynamic_mark_midi [Pp .. Ff] == [39,50,61,72,83,94] > map dynamic_mark_midi [Fp,Sf,Sfp,Sfpp,Sfz,Sffz] == replicate 6 Nothing -} dynamic_mark_midi :: (Num n,Enum n) => Dynamic_Mark -> Maybe n dynamic_mark_midi m = let r = zip [0..] (0 : reverse [127, 127-11 .. 0]) in lookup (fromEnum m) r -- | Error variant. dynamic_mark_midi_err :: Integral n => Dynamic_Mark -> n dynamic_mark_midi_err = fromMaybe (error "dynamic_mark_midi") . dynamic_mark_midi {- | Map midi velocity (0-127) to dynamic mark. > histogram (mapMaybe midi_dynamic_mark [0 .. 127]) -} midi_dynamic_mark :: (Ord n,Num n,Enum n) => n -> Maybe Dynamic_Mark midi_dynamic_mark m = let r = zip (0 : [12,24 .. 132]) [0..] in fmap (toEnum . snd) (find ((>= m) . fst) r) {- | Translate /fixed/ 'Dynamic_Mark's to /db/ amplitude over given /range/. > mapMaybe (dynamic_mark_db 120) [Niente,P,F,Fffff] == [-120,-70,-40,0] > mapMaybe (dynamic_mark_db 60) [Niente,P,F,Fffff] == [-60,-35,-20,0] -} dynamic_mark_db :: Fractional n => n -> Dynamic_Mark -> Maybe n dynamic_mark_db r m = let u = [Niente .. Fffff] n = length u - 1 k = r / fromIntegral n f i = negate r + (fromIntegral i * k) in fmap f (elemIndex m u) {- | > import Sound.Sc3.Plot {- hsc3-plot -} > plot_p1_ln [map (ampmidid 20) [0 .. 127],map (ampmidid 60) [0 .. 127]] -} ampmidid :: Floating a => a -> a -> a ampmidid db v = let r = 10 ** (db / 20) b = 127 / (126 * sqrt r) - 1 / 126 m = (1 - b) / 127 in (m * v + b) ** 2 {- | JMcC (Sc3) equation. > plot_p1_ln [map amp_db [0,0.005 .. 1]] -} amp_db :: Floating a => a -> a amp_db a = logBase 10 a * 20 {- | JMcC (Sc3) equation. > plot_p1_ln [map db_amp [-60,-59 .. 0]] -} db_amp :: Floating a => a -> a db_amp a = 10 ** (a * 0.05) -- | Enumeration of hairpin indicators. data Hairpin = Crescendo | Diminuendo | End_Hairpin deriving (Eq,Ord,Enum,Bounded,Show) {- | The 'Hairpin' implied by a ordered pair of 'Dynamic_Mark's. > map (implied_hairpin Mf) [Mp,F] == [Just Diminuendo,Just Crescendo] -} implied_hairpin :: Dynamic_Mark -> Dynamic_Mark -> Maybe Hairpin implied_hairpin p q = case compare p q of LT -> Just Crescendo EQ -> Nothing GT -> Just Diminuendo -- | A node in a dynamic sequence. type Dynamic_Node = (Maybe Dynamic_Mark,Maybe Hairpin) -- | The empty 'Dynamic_Node'. empty_dynamic_node :: Dynamic_Node empty_dynamic_node = (Nothing,Nothing) {- | Calculate a 'Dynamic_Node' sequence from a sequence of 'Dynamic_Mark's. > let r = [(Just Pp,Just Crescendo), (Just Mp,Just End_Hairpin) ,(Nothing,Just Diminuendo) ,(Just Pp,Just End_Hairpin)] > dynamic_sequence [Pp,Mp,Mp,Pp] == r -} dynamic_sequence :: [Dynamic_Mark] -> [Dynamic_Node] dynamic_sequence d = let h = zipWith implied_hairpin d (tail d) ++ [Nothing] e = Just End_Hairpin rec i p = case p of [] -> [] [(j,_)] -> if i then [(j,e)] else [(j,Nothing)] (j,k):p' -> case k of Nothing -> if i then (j,e) : rec False p' else (j,k) : rec False p' Just _ -> (j,k) : rec True p' in rec False (zip (T.indicate_repetitions d) h) {- | Delete redundant (unaltered) dynamic marks. > let r = [Just P,Nothing,Nothing,Nothing,Just F] > delete_redundant_marks [Just P,Nothing,Just P,Just P,Just F] == r -} delete_redundant_marks :: [Maybe Dynamic_Mark] -> [Maybe Dynamic_Mark] delete_redundant_marks = let f i j = case (i,j) of (Just a,Just b) -> if a == b then (j,Nothing) else (j,j) (Just _,Nothing) -> (i,Nothing) (Nothing,_) -> (j,j) in snd . mapAccumL f Nothing {- | Variant of 'dynamic_sequence' for sequences of 'Dynamic_Mark' with holes (ie. rests). Runs 'delete_redundant_marks'. > let r = [Just (Just P,Just Crescendo),Just (Just F,Just End_Hairpin),Nothing,Just (Just P,Nothing)] > dynamic_sequence_sets [Just P,Just F,Nothing,Just P] == r > dynamic_sequence_sets [Just P,Nothing,Just P] == [Just (Just P,Nothing),Nothing,Nothing] -} dynamic_sequence_sets :: [Maybe Dynamic_Mark] -> [Maybe Dynamic_Node] dynamic_sequence_sets = let f l = case l of Nothing:_ -> map (const Nothing) l _ -> map Just (dynamic_sequence (catMaybes l)) in concatMap f . T.group_just . delete_redundant_marks {- | Apply 'Hairpin' and 'Dynamic_Mark' functions in that order as required by 'Dynamic_Node'. > let f _ x = show x > apply_dynamic_node f f (Nothing,Just Crescendo) undefined -} apply_dynamic_node :: (a -> Dynamic_Mark -> a) -> (a -> Hairpin -> a) -> Dynamic_Node -> a -> a apply_dynamic_node f g (i,j) m = let n = maybe m (g m) j in maybe n (f n) i -- * Ascii -- | Ascii pretty printer for 'Dynamic_Mark'. dynamic_mark_ascii :: Dynamic_Mark -> String dynamic_mark_ascii = map toLower . show -- | Ascii pretty printer for 'Hairpin'. hairpin_ascii :: Hairpin -> String hairpin_ascii hp = case hp of Crescendo -> "<" Diminuendo -> ">" End_Hairpin -> "" -- | Ascii pretty printer for 'Dynamic_Node'. dynamic_node_ascii :: Dynamic_Node -> String dynamic_node_ascii (mk,hp) = let mk' = maybe "" dynamic_mark_ascii mk hp' = maybe "" hairpin_ascii hp in case (mk',hp') of ([],[]) -> [] ([],_) -> hp' (_,[]) -> mk' _ -> mk' ++ " " ++ hp' -- | Ascii pretty printer for 'Dynamic_Node' sequence. dynamic_sequence_ascii :: [Dynamic_Node] -> String dynamic_sequence_ascii = unwords . filter (not . null) . map dynamic_node_ascii