module Music.Theory.Dynamic_Mark where
import Data.List
import Data.Maybe
import Music.Theory.List
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_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)
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 (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 . 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