module Music.LilyPond.Light.Annotation where
import Data.Maybe
import Data.Monoid
import Music.LilyPond.Light.Constant
import Music.LilyPond.Light.Model
import Music.LilyPond.Light.Notation
import Music.LilyPond.Light.Output.LilyPond
import Music.Theory.Pitch
allows_annotations :: Music -> Bool
allows_annotations m =
is_note m ||
is_chord m ||
is_rest m ||
is_mm_rest m
add_annotation :: Annotation -> Music -> Maybe Music
add_annotation a m =
case m of
Note n d as -> Just (Note n d (as ++ [a]))
Chord n d as -> Just (Chord n d (as ++ [a]))
Rest d as -> Just (Rest d (as ++ [a]))
Skip d as -> Just (Skip d (as ++ [a]))
MMRest i j as -> Just (MMRest i j (as ++ [a]))
Command c as -> Just (Command c (as ++ [a]))
_ -> Nothing
add_annotation_err :: Annotation -> Music -> Music
add_annotation_err a m =
let err = error ("add_annotation: " ++ show (a,ly_music_elem m))
in fromMaybe err (add_annotation a m)
(&) :: Music -> Annotation -> Music
m & a = add_annotation_err a m
(&#) :: Pitch -> Annotation -> Music
x &# y = Note x Nothing [y]
perhaps_annotate :: Annotation -> Music -> Music
perhaps_annotate a m = fromMaybe m (add_annotation a m)
bracket_annotation_fn :: (Annotation -> Music -> Music) ->
(Annotation,Annotation) -> [Music] -> [Music]
bracket_annotation_fn fn (begin, end) xs =
let x0 = head xs
xn = last xs
xs' = drop 1 (reverse (drop 1 (reverse xs)))
xs_e = show (map ly_music_elem xs)
in if length xs >= 2
then [fn begin x0] ++ xs' ++ [fn end xn]
else error ("bracket_annotation failed: " ++ xs_e)
bracket_annotation :: (Annotation,Annotation) -> [Music] -> [Music]
bracket_annotation = bracket_annotation_fn add_annotation_err
bracket_annotation' :: (Annotation,Annotation) -> [Music] -> [Music]
bracket_annotation' a x =
case x of
(_:_:_) -> bracket_annotation_fn perhaps_annotate a x
_ -> x
beam' :: [Music] -> [Music]
beam' = bracket_annotation (begin_beam, end_beam)
beam :: [Music] -> Music
beam = mconcat . beam'
slur' :: [Music] -> [Music]
slur' = bracket_annotation (begin_slur, end_slur)
slur :: [Music] -> Music
slur = mconcat . slur'
phrasing_slur' :: [Music] -> [Music]
phrasing_slur' =
let a = (begin_phrasing_slur, end_phrasing_slur)
in bracket_annotation a
phrasing_slur :: [Music] -> Music
phrasing_slur = mconcat . phrasing_slur'
text_above,text_below,text_mark :: String -> Annotation
text_above x = CompositeAnnotation [Place_Above, Text Text_Plain x]
text_below x = CompositeAnnotation [Place_Below, Text Text_Plain x]
text_mark x = CompositeAnnotation [Text_Mark, Text Text_Plain x]
text_above_fmt,text_below_fmt,text_mark_fmt :: String -> Annotation
text_above_fmt x = CompositeAnnotation [Place_Above,Text Text_Markup x]
text_below_fmt x = CompositeAnnotation [Place_Below,Text Text_Markup x]
text_mark_fmt x = CompositeAnnotation [Text_Mark, Text Text_Markup x]
arco,pizz :: Annotation
arco = text_above "arco"
pizz = text_above "pizz."
place_above,place_below :: Annotation -> Annotation
place_above x = CompositeAnnotation [Place_Above, x]
place_below x = CompositeAnnotation [Place_Below, x]
note_annotate :: Annotation -> Music -> Music
note_annotate a m =
case m of
Note n d xs -> Note n d (xs++[a])
_ -> m
initial_note_chord_annotate :: Annotation -> [Music] -> [Music]
initial_note_chord_annotate a m =
case m of
[] -> []
(x:xs) -> if is_note x || is_chord x
then x & a : xs
else x : initial_note_chord_annotate a xs
allows_indirect_annotation :: Music -> Bool
allows_indirect_annotation m =
case m of
Grace x -> allows_indirect_annotation x
AfterGrace x _ -> allows_indirect_annotation x
Tuplet _ _ x -> allows_indirect_annotation x
Join (x:_) -> allows_indirect_annotation x
_ -> allows_annotations m
indirect_annotation :: Annotation -> Music -> Music
indirect_annotation a m =
case m of
Grace x -> Grace (indirect_annotation a x)
AfterGrace x1 x2 -> AfterGrace (indirect_annotation a x1) x2
Tuplet tm tt x -> Tuplet tm tt (indirect_annotation a x)
Join (x:xs) -> Join (indirect_annotation a x : xs)
_ -> m & a
attach_indirect_annotation :: Annotation -> [Music] -> [Music]
attach_indirect_annotation a m =
case m of
[] -> error "attach_indirect_annotation"
x:xs -> if allows_indirect_annotation x
then indirect_annotation a x : xs
else x : attach_indirect_annotation a xs
r_acc :: Music -> Music
r_acc x = x &rAcc
c_acc :: Music -> Music
c_acc x = x &cAcc
p_cmp :: (t1 -> t2 -> t) -> (t3 -> t1) -> (t3 -> t2) -> t3 -> t
p_cmp fn p1 p2 x = p1 x `fn` p2 x
p_or :: (t -> Bool) -> (t -> Bool) -> t -> Bool
p_or = p_cmp (||)
p_and :: (t -> Bool) -> (t -> Bool) -> t -> Bool
p_and = p_cmp (&&)
span_r :: (a -> Bool) -> [a] -> ([a], [a], [a])
span_r fn xs =
let (o1,o2) = span fn xs
(o3,o4) = span fn (reverse o2)
in (o1,reverse o4, reverse o3)
perhaps_beam :: [Music] -> [Music]
perhaps_beam xs =
case xs of
[] -> []
[x] -> [x]
_ -> beam' xs
beam_notes :: [Music] -> Music
beam_notes xs =
let (x1,x2,x3) = span_r (not . p_or is_note is_chord) xs
in mconcat (x1 ++ perhaps_beam x2 ++ x3)
set_subdivide_beams :: Integer -> Music
set_subdivide_beams i =
let x0 = "\\set subdivideBeams = ##t"
x1 = "\\set baseMoment = #(ly:make-moment 1 " ++ show i ++ ")"
in mconcat [Command (User x0) [], Command (User x1) []]