module Music.Typesetting.Query where
import Data.Function
import Data.List
import Data.Maybe
import Music.Theory.Dynamic_Mark
import Music.Theory.Duration
import Music.Theory.Duration.Name
import Music.Theory.Duration.RQ
import Music.Theory.Pitch
import Music.Theory.Tempo_Marking
import Music.Theory.Time_Signature
import Music.Typesetting.Model
na_pitch :: N_Annotation -> Maybe Pitch
na_pitch a =
case a of
N_Pitch x -> Just x
_ -> Nothing
na_dynamic_mark :: N_Annotation -> Maybe Dynamic_Mark_T
na_dynamic_mark a =
case a of
N_Direction (D_Dynamic_Mark x) -> Just x
_ -> Nothing
na_is_dynamic_mark :: N_Annotation -> Bool
na_is_dynamic_mark = isJust . na_dynamic_mark
na_is_dynamic_annotation :: N_Annotation -> Bool
na_is_dynamic_annotation a =
case a of
N_Direction (D_Dynamic_Mark _) -> True
N_Direction (D_Hairpin _) -> True
_ -> False
na_is_begin_hairpin :: N_Annotation -> Bool
na_is_begin_hairpin a =
case a of
N_Direction (D_Hairpin Crescendo) -> True
N_Direction (D_Hairpin Diminuendo) -> True
_ -> False
na_is_begin_dynamic :: N_Annotation -> Bool
na_is_begin_dynamic a = na_is_dynamic_mark a || na_is_begin_hairpin a
na_annotated_tied_lr :: [N_Annotation] -> (Bool,Bool)
na_annotated_tied_lr a = (N_End_Tied `elem` a,N_Begin_Tied `elem` a)
data At_Tied = At_End_Tied | At_Either_Tied | At_Begin_Tied
deriving (Eq,Enum,Ord,Show)
na_annotation_at_tied :: N_Annotation -> At_Tied
na_annotation_at_tied a =
let err = error (show ("na_annotation_at_tied",a))
in case a of
N_Grace -> At_Begin_Tied
N_Chord -> At_Either_Tied
N_Pitch _ -> At_Either_Tied
N_Unpitched -> At_Either_Tied
N_Rest -> At_Either_Tied
N_Notehead _ -> At_Either_Tied
N_Staff _ -> At_Either_Tied
N_Beam _ _ -> At_Either_Tied
N_Begin_Tied -> At_End_Tied
N_End_Tied -> At_Begin_Tied
N_Begin_Slur -> At_Begin_Tied
N_End_Slur -> At_End_Tied
N_Begin_Tuplet _ -> err
N_End_Tuplet -> err
N_Begin_Glissando -> At_End_Tied
N_End_Glissando -> At_Begin_Tied
N_Begin_Slide -> At_End_Tied
N_End_Slide -> At_Begin_Tied
N_Stem_Tremolo _ -> At_Either_Tied
N_Ornament Trill_Mark -> At_Begin_Tied
N_Technical _ -> At_Begin_Tied
N_Articulation _ -> At_Begin_Tied
N_Fermata -> At_End_Tied
N_Arpeggiate -> At_Begin_Tied
N_Direction (D_Dynamic_Mark _) -> At_Begin_Tied
N_Direction (D_Hairpin Crescendo) -> At_Begin_Tied
N_Direction (D_Hairpin Diminuendo) -> At_Begin_Tied
N_Direction (D_Hairpin End_Hairpin) -> At_End_Tied
N_Direction (D_Words Above "l.v.") -> At_End_Tied
N_Direction (D_Words _ _) -> At_Begin_Tied
N_Direction (D_Rehearsal _) -> At_Begin_Tied
N_Direction (D_Tempo_Marking _) -> At_Begin_Tied
N_Direction (D_Pedal {}) -> At_Begin_Tied
N_Voice _ -> At_Either_Tied
N_Backup _ -> err
na_annotation_at_end_tied_only :: N_Annotation -> Bool
na_annotation_at_end_tied_only = (== At_End_Tied) . na_annotation_at_tied
na_annotation_at_tied_either :: N_Annotation -> Bool
na_annotation_at_tied_either = (== At_Either_Tied) . na_annotation_at_tied
n_has_annotation :: N_Annotation -> Note -> Bool
n_has_annotation x (Note _ xs) = x `elem` xs
n_is_rest :: Note -> Bool
n_is_rest = n_has_annotation N_Rest
n_is_chord_elem :: Note -> Bool
n_is_chord_elem = n_has_annotation N_Chord
n_is_untied :: Note -> Bool
n_is_untied n =
not (n_has_annotation N_Begin_Tied n ||
n_has_annotation N_End_Tied n)
n_is_initial_tie :: Note -> Bool
n_is_initial_tie n =
n_has_annotation N_Begin_Tied n &&
not (n_has_annotation N_End_Tied n)
n_is_final_tie :: Note -> Bool
n_is_final_tie n =
n_has_annotation N_End_Tied n &&
not (n_has_annotation N_Begin_Tied n)
n_pitch :: Note -> Maybe Pitch
n_pitch (Note _ as) =
case mapMaybe na_pitch as of
[] -> Nothing
[x] -> Just x
_ -> error "n_pitch"
n_has_pitch :: Note -> Bool
n_has_pitch = isJust . n_pitch
n_dynamic_mark :: Note -> Maybe Dynamic_Mark_T
n_dynamic_mark (Note _ as) =
case mapMaybe na_dynamic_mark as of
[] -> Nothing
[x] -> Just x
_ -> error "n_dynamic_mark: multiple marks"
n_has_dynamic_mark :: Note -> Bool
n_has_dynamic_mark = isJust . n_dynamic_mark
n_duration_forward :: Note -> Maybe Duration
n_duration_forward n =
let (Note d _) = n
in if n_is_chord_elem n
then Nothing
else Just d
ma_time_signature_t :: M_Annotation -> Maybe Time_Signature
ma_time_signature_t m =
case m of
M_Time_Signature x -> Just x
_ -> Nothing
ma_tempo_marking_t:: M_Annotation -> Maybe Tempo_Marking
ma_tempo_marking_t a =
case a of
M_Direction (D_Tempo_Marking x) -> Just x
_ -> Nothing
list_to_maybe :: [a] -> Maybe a
list_to_maybe l =
case l of
[e] -> Just e
_ -> Nothing
m_time_signature :: Measure -> [M_Annotation]
m_time_signature = filter (isJust . ma_time_signature_t) . m_annotations
m_time_signature' :: Measure -> Maybe M_Annotation
m_time_signature' = list_to_maybe . m_time_signature
m_time_signature_t :: Measure -> [Time_Signature]
m_time_signature_t = mapMaybe ma_time_signature_t . m_annotations
m_tempo_marking :: Measure -> [M_Annotation]
m_tempo_marking = filter (isJust . ma_tempo_marking_t) . m_annotations
m_tempo_marking' :: Measure -> Maybe M_Annotation
m_tempo_marking' = list_to_maybe . m_tempo_marking
m_tempo_marking_t :: Measure -> [Tempo_Marking]
m_tempo_marking_t = mapMaybe ma_tempo_marking_t . m_annotations
type SI_Map a = [(Integer,a)]
type Time_Signature_Map = SI_Map Time_Signature
type Tempo_Marking_Map = SI_Map Tempo_Marking
type Temporal_Map = (Integer,Time_Signature_Map,Tempo_Marking_Map)
si_map_to_sequence :: Integer -> a -> SI_Map a -> [a]
si_map_to_sequence n df mp =
let mp' = (0,df) : mp ++ [(n,undefined)]
fn (i,x) (j,_) = genericReplicate (j i) x
in concat (zipWith fn mp' (tail mp'))
mm_time_signature_map :: [Measure] -> Time_Signature_Map
mm_time_signature_map =
let fn (i,m) = case m_time_signature_t m of
[] -> Nothing
[x] -> Just (i,x)
_ -> error "mm_time_signature_map"
in mapMaybe fn . zip [0..]
mm_tempo_marking_map :: [Measure] -> Tempo_Marking_Map
mm_tempo_marking_map =
let fn (i,m) = case m_tempo_marking_t m of
[] -> Nothing
[x] -> Just (i,x)
_ -> error "mm_tempo_marking_map"
in mapMaybe fn . zip [0..]
mm_temporal_map :: [Measure] -> Temporal_Map
mm_temporal_map xs =
let ts_m = mm_time_signature_map xs
tm_m = mm_tempo_marking_map xs
in (genericLength xs,ts_m,tm_m)
integrate :: (Num a) => [a] -> [a]
integrate = scanl1 (+)
temporal_map_locate :: Temporal_Map -> [(Rational,Rational,Tempo_Marking)]
temporal_map_locate (n,ts_m,tm_m) =
let ts_s = si_map_to_sequence n (4,4) ts_m
tm_s = si_map_to_sequence n (quarter_note,60) tm_m
dd = zipWith measure_duration ts_s tm_s
st = 0 : integrate dd
in zip3 st dd tm_s
n_locate :: (Rational,Rational,Tempo_Marking) -> [Note] -> [(Rational,Note)]
n_locate (st,_,tm) =
let fn i n = let j = maybe 0 duration_to_rq (n_duration_forward n)
j' = rq_to_seconds tm j
in (i + j', (i,n))
in snd . mapAccumL fn st
locate_notes :: [[Measure]] -> [(Rational,Note)]
locate_notes mms =
let tm = mm_temporal_map (head mms)
lm = temporal_map_locate tm
mk_ns ms = concat (zipWith n_locate lm (map m_notes ms))
in sortBy (compare `on` fst) (concatMap mk_ns mms)