module Music.Theory.Dynamic_Mark where
import Data.Char
import Data.List
import Data.Maybe
import qualified Music.Theory.List as T
data Dynamic_Mark_T = 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)
dynamic_mark_midi :: (Num n,Enum n) => Dynamic_Mark_T -> Maybe n
dynamic_mark_midi m =
let r = zip [0..] (0 : reverse [127, 12711 .. 0])
in lookup (fromEnum m) r
dynamic_mark_midi_err :: Integral n => Dynamic_Mark_T -> n
dynamic_mark_midi_err = fromMaybe (error "dynamic_mark_midi") . dynamic_mark_midi
midi_dynamic_mark :: (Ord n,Eq n,Num n,Enum n) => n -> Maybe Dynamic_Mark_T
midi_dynamic_mark m =
let r = zip (0 : [12,24 .. 132]) [0..]
in fmap (toEnum . snd) (find ((>= m) . fst) r)
dynamic_mark_db :: Fractional n => n -> Dynamic_Mark_T -> 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)
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
amp_db :: Floating a => a -> a
amp_db a = logBase 10 a * 20
db_amp :: Floating a => a -> a
db_amp a = 10 ** (a * 0.05)
data Hairpin_T = Crescendo | Diminuendo | End_Hairpin
deriving (Eq,Ord,Enum,Bounded,Show)
implied_hairpin :: Dynamic_Mark_T -> Dynamic_Mark_T -> Maybe Hairpin_T
implied_hairpin p q =
case compare p q of
LT -> Just Crescendo
EQ -> Nothing
GT -> Just Diminuendo
type Dynamic_Node = (Maybe Dynamic_Mark_T,Maybe Hairpin_T)
empty_dynamic_node :: Dynamic_Node
empty_dynamic_node = (Nothing,Nothing)
dynamic_sequence :: [Dynamic_Mark_T] -> [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_marks :: [Maybe Dynamic_Mark_T] -> [Maybe Dynamic_Mark_T]
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
dynamic_sequence_sets :: [Maybe Dynamic_Mark_T] -> [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_dynamic_node :: (a -> Dynamic_Mark_T -> a) -> (a -> Hairpin_T -> 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
dynamic_mark_ascii :: Dynamic_Mark_T -> String
dynamic_mark_ascii = map toLower . show
hairpin_ascii :: Hairpin_T -> String
hairpin_ascii hp =
case hp of
Crescendo -> "<"
Diminuendo -> ">"
End_Hairpin -> ""
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'
dynamic_sequence_ascii :: [Dynamic_Node] -> String
dynamic_sequence_ascii =
intercalate " " .
filter (not . null) .
map dynamic_node_ascii