Light.hs

module Music.LilyPond.Light (module Music.LilyPond.Light
                            ,module L) where

import Data.List
import Data.Monoid
import Data.Ratio
import Music.LilyPond.Light.Constant as L
import Music.LilyPond.Light.Constant.NoteName as L
import Music.LilyPond.Light.Model as L
import Music.LilyPond.Light.Output.LilyPond as L
import Music.Theory.Duration as L
import Music.Theory.Duration.Name as L
import Music.Theory.Key as L
import Music.Theory.Pitch as L
import Music.Theory.Pitch.Spelling

-- * Music category predicates

is_music_c :: Music_C -> Music -> Bool
is_music_c c = (==) c . music_c

is_note :: Music -> Bool
is_note = is_music_c Note_C

is_chord :: Music -> Bool
is_chord = is_music_c Chord_C

is_rest :: Music -> Bool
is_rest = is_music_c Rest_C

is_mm_rest :: Music -> Bool
is_mm_rest = is_music_c MMRest_C

is_grace :: Music -> Bool
is_grace = is_music_c Grace_C

is_after_grace :: Music -> Bool
is_after_grace = is_music_c AfterGrace_C

-- | These are required to avoid issues in lilypond (see manual)
is_grace_skip :: Music -> Bool
is_grace_skip m =
    case m of
      Grace (Skip _) -> True
      _ -> False

is_clef :: Music -> Bool
is_clef = is_music_c Clef_C

is_time :: Music -> Bool
is_time = is_music_c Time_C

is_tempo :: Music -> Bool
is_tempo = is_music_c Tempo_C

is_barlinecheck :: Music -> Bool
is_barlinecheck m =
    case m of
      Command BarlineCheck -> True
      _ -> False

is_tied :: Music -> Bool
is_tied m =
    case m of
      Note _ _ xs -> Begin_Tie `elem` xs
      Chord _ _ xs -> Begin_Tie `elem` xs
      _ -> False

is_tuplet :: Music -> Bool
is_tuplet = is_music_c Tuplet_C

-- * Pitch

-- | Add reminder accidental to note.
r_acc :: Music -> Music
r_acc x = x &rAcc

-- | Add cautionary accidental to note.
c_acc :: Music -> Music
c_acc x = x &cAcc

-- | Remove any reminder or cautionary accidentals at note or chord.
clr_acc :: Music -> Music
clr_acc m =
    let rl = [rAcc,cAcc]
    in case m of
         Note x d a -> Note x d (a \\ rl)
         Chord xs d a -> Chord (map clr_acc xs) d a
         _ -> error ("clr_acc at non-note/chord: " ++ ly_music_elem m)

octpc_to_note :: (Octave, PitchClass) -> Music
octpc_to_note x = Note (octpc_to_pitch pc_spell_ks x) Nothing []

-- * Rests

-- | Construct rests.
r :: Duration -> Music
r x = Rest x []

-- | Multi-measure variant of 'r'.
r' :: TimeSignature -> Music
r' x = MMRest 1 x []

-- | Create an empty measure for the specified time signature.
empty_measure :: Integer -> Integer -> Music
empty_measure n d = mconcat [MMRest 1 (n,d) [], l]

-- | Like 'empty_measure', but with an invisible rest.
null_measure :: Integer -> Integer -> Music
null_measure n d =
    let x = Duration d 0 1
    in mconcat (map Skip (genericReplicate n x) ++ [l])

-- | Like 'empty_measure' but write time signature.
measure_rest :: Integer -> Integer -> Music
measure_rest n d = mconcat [time_signature (n,d), empty_measure n d]

-- | Like 'measure_rest' but write time signature.
measure_null :: Integer -> Integer -> Music
measure_null n d = mconcat [time_signature (n,d), null_measure n d]

-- * Measures

type M_Annotation = Music
data Measure = Measure [M_Annotation] [Music]

m_annotate :: M_Annotation -> Measure -> Measure
m_annotate a (Measure as xs) = Measure (as++[a]) xs

m_annotate' :: [M_Annotation] -> Measure -> Measure
m_annotate' as' (Measure as xs) = Measure (as++as') xs

m_annotate_first' :: [M_Annotation] -> [Measure] -> [Measure]
m_annotate_first' as xs =
    case xs of
      (x:xs') -> m_annotate' as x : xs'
      [] -> error "m_annotate_first'"

m_annotate_last' :: [M_Annotation] -> [Measure] -> [Measure]
m_annotate_last' as xs =
    case xs of
      [] -> []
      [x] -> [m_annotate' as x]
      (x:xs') -> x : m_annotate_last' as xs'

m_append :: [Music] -> Measure -> Measure
m_append c (Measure as xs) = Measure as (xs++c)

m_elements :: Measure -> [Music]
m_elements (Measure as xs) = as ++ xs

mm_elements :: [Measure] -> [Music]
mm_elements = concat . map m_elements

-- * Tuplets

-- | Apply a 'Duration' function to a 'Music' node, if it has a duration.
edit_dur :: (Duration -> Duration) -> Music -> Music
edit_dur fn x =
    case x of
      Note _ Nothing _ -> x
      Note n (Just d) a -> Note n (Just (fn d)) a
      Chord n d a -> Chord n (fn d) a
      Rest d a -> Rest (fn d) a
      Skip d -> Skip (fn d)
      _ -> x

-- | Temporal scaling of music (tuplets).
tuplet :: Tuplet_T -> [Music] -> Music
tuplet (d,n) =
    let fn x = x { multiplier = n%d }
    in Tuplet Normal_Tuplet (n,d) . mconcat . map (edit_dur fn)

-- | Tuplet variants that set location, and then restore to neutral.
tuplet_above,tuplet_below :: Tuplet_T -> [Music] -> Music
tuplet_above n xs = mconcat [tuplet_up, tuplet n xs, tuplet_neutral]
tuplet_below n xs = mconcat [tuplet_down, tuplet n xs, tuplet_neutral]

-- | Like tuplet but does not annotate music, see also
--   'ts_set_fraction'.
scale_durations :: Tuplet_T -> [Music] -> Music
scale_durations (n,d) =
    let fn x = x { multiplier = d%n }
    in Tuplet Scale_Durations (n,d) . mconcat . map (edit_dur fn)

-- * Time signatures

-- | Construct time signature.
time_signature :: TimeSignature -> Music
time_signature = Time

-- | Allow proper auto-indenting of multiple measures with the same
--   time signature.
with_time_signature :: TimeSignature -> [Music] -> Music
with_time_signature ts xs = mconcat (time_signature ts : xs)

{-
-- | Make a duration to fill a whole measure.
ts_dur :: TimeSignature -> Duration
ts_dur (n,d) = Duration d 0 (fromIntegral n)
-}

-- | Tied, non-multiplied durations to fill a whole measure.
ts_whole_note :: TimeSignature -> [Duration]
ts_whole_note t =
    case t of
      (1,2) -> [half_note]
      (2,16) -> [eighth_note]
      (2,8) -> [quarter_note]
      (2,4) -> [half_note]
      (2,2) -> [whole_note]
      (3,16) -> [dotted_eighth_note]
      (3,8) -> [dotted_quarter_note]
      (3,4) -> [dotted_half_note]
      (3,2) -> [dotted_whole_note]
      (4,16) -> [quarter_note]
      (4,8) -> [half_note]
      (4,4) -> [whole_note]
      (4,2) -> [breve]
      (5,16) -> [quarter_note,sixteenth_note]
      (5,8) -> [half_note,eighth_note]
      (5,4) -> [whole_note,quarter_note]
      (6,2) -> [dotted_breve]
      _ -> error ("ts_whole_note: " ++ show t)

-- | Command to request that @4\/4@ and @2\/2@ etc. are typeset as
-- fractions.
ts_use_fractions :: Music
ts_use_fractions =
    let x = "\\override Staff.TimeSignature #'style = #'()"
    in Command (User x)

-- | Set the printed time-signature fraction.
ts_set_fraction :: Integer -> Integer -> Music
ts_set_fraction n d =
    let x = "#'(" ++ show n ++ " . " ++ show d ++ ")"
        y = "\\set Staff.timeSignatureFraction = " ++ x
    in Command (User y)

numeric_time_signature :: Music
numeric_time_signature = Command (User "\\numericTimeSignature")

ts_parentheses :: Music
ts_parentheses =
    let x = "\\override Staff.TimeSignature #'stencil = #(lambda (grob) (bracketify-stencil (ly:time-signature::print grob) Y 0.1 0.2 0.1))"
    in Command (User x)

-- * Key signatures

-- | Construct key signature.
key :: Music -> Mode_T -> Music
key (Note (Pitch n a _) _ _) md = Key n (Just a) md
key _ _ = error "key"

-- * Repetition

-- | Construct standard (two times) repeat.
std_repeat :: Integer -> [Music] -> Music
std_repeat n = Repeat n . mconcat

-- * Annotations

-- | Can a 'Music' element be annotated?
allows_annotations :: Music -> Bool
allows_annotations m =
    is_note m ||
    is_chord m ||
    is_rest m ||
    is_mm_rest m

-- | Attempt to add an 'Annotation' to a 'Music' element.
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]))
      MMRest i j as -> Just (MMRest i j (as ++ [a]))
      _ -> Nothing

-- | Add an 'Annotation' to a 'Music' element or 'error'.
add_annotation_err :: Annotation -> Music -> Music
add_annotation_err a m =
    case add_annotation a m of
      Just m' -> m'
      Nothing -> error ("add_annotation failed: " ++ show (a,ly_music_elem m))

-- | Infix form of 'add_annotation_err'.
(&) :: Music -> Annotation -> Music
m & a = add_annotation_err a m

-- | Add an 'Annotation' to a 'Pitch'.
(&#) :: Pitch -> Annotation -> Music
x &# y = Note x Nothing [y]

-- | Add an 'Annotation' to a 'Music' element.
perhaps_annotate :: Annotation -> Music -> Music
perhaps_annotate a m = maybe m id (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)

-- | Manual beaming.
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 :: String -> Annotation
text_above x = CompositeAnnotation [Above, Text x]
text_below x = CompositeAnnotation [Below, Text x]

arco,pizz :: Annotation
arco = text_above "arco"
pizz = text_above "pizz."

stem_tremolo :: Integer -> Annotation
stem_tremolo = Articulation . StemTremolo

place_above,place_below :: Annotation -> Annotation
place_above x = CompositeAnnotation [Above, x]
place_below x = CompositeAnnotation [Below, x]

-- | Add an 'Annotation' to a @Note@ 'Music' element, else identity.
note_annotate :: Annotation -> Music -> Music
note_annotate a m =
    case m of
      Note n d xs -> Note n d (xs++[a])
      _ -> m

-- | Annotate the first note/chord element.
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

-- * Indirect annotations

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 _ [] = error "attach_indirect_annotation"
attach_indirect_annotation a (x:xs) =
    if allows_indirect_annotation x
    then indirect_annotation a x : xs
    else x : attach_indirect_annotation a xs

-- * Octave

-- | Shift the octave of a note element, else identity.
note_edit_octave :: (Integer -> Integer) -> Music -> Music
note_edit_octave fn m =
    case m of
      Note (Pitch n a o) d xs -> Note (Pitch n a (fn o)) d xs
      _ -> m

-- | Shift the octave of a note element, else identity.
note_shift_octave :: Integer -> Music -> Music
note_shift_octave i = note_edit_octave (+ i)

-- * Beaming

-- | Predicate combinators.
p_or, p_and :: (t -> Bool) -> (t -> Bool) -> t -> Bool
p_or p1 p2 = \x -> p1 x || p2 x
p_and p1 p2 = \x -> p1 x && p2 x

-- | Variant of 'span' that further spans the reverse of the right
-- hand side.
--
--  > span_r (< 0) [-1,-2,1,2,3,-3,-4] == ([-1,-2],[1,2,3],[-3,-4])
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)

-- | Beam if at least two elements.
perhaps_beam :: [Music] -> [Music]
perhaps_beam xs =
    case xs of
      [] -> []
      [x] -> [x]
      _ -> beam' xs

-- | Beam interior notes/chords (ie. skip exterior
--   non-note/non-chords).
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)

-- 2.13.29 (Issue #1083)
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)]

-- * Duration

-- | Add 'Duration' to 'Pitch' to make a @Note@ 'Music' element.
(##) :: Pitch -> Duration -> Music
x ## d = Note x (Just d) []

-- | Add 'Duration' to either a @Note@ or @Chord@ 'Music' element.
(#) :: Music -> Duration -> Music
x # d =
    case x of
      Note n _ a -> Note n (Just d) a
      Chord n _ a -> Chord n d a
      _ -> error ("##: " ++ show x)

-- * Chords

-- | Construct chord.
chd_p :: [Pitch] -> Duration -> Music
chd_p [] _ = error "chd_p: null elements"
chd_p xs d = Chord (map (\x -> Note x Nothing []) xs) d []

chd :: [Music] -> Duration -> Music
chd [] _ = error "chd: null elements"
chd xs d =
    let fn x =
            let err msg = error (msg ++ ": " ++ show x)
            in case x of
              Note _ (Just _) _ -> err "chd: note has duration"
              Note _ Nothing _ -> x
              _ -> err "chd: non note element"
    in Chord (map fn xs) d []

-- * Commands

-- | Construct bar number check command.
bar_number_check :: Integer -> Music
bar_number_check = Command . BarNumberCheck

-- | Change staff.
change :: String -> Music
change x = Command (Change x)

-- | Indicate initial partial measure.
partial :: Duration -> Music
partial = Command . Partial

-- | Set or unset the @circled-tip@ hairpin attribute.
hairpin_circled_tip :: Bool -> Music
hairpin_circled_tip x =
    let c = if x
            then "\\override Hairpin #'circled-tip = ##t"
            else "\\revert Hairpin #'circled-tip"
    in Command (User c)

-- | Set or unset the @to-barline@ hairpin attribute.
hairpin_to_barline :: Bool -> Music
hairpin_to_barline x =
    let c = if x
            then "\\revert Hairpin #'to-barline"
            else "\\override Hairpin #'to-barline = ##f"
    in Command (User c)

-- * Staff and Parts

name_to_id :: Staff_Name -> Staff_ID
name_to_id (x,_) =
    case x of
      "" -> "no_id"
      _ -> "id_" ++ x

-- | Construct staff.
staff :: Staff_Name -> [Music] -> Staff
staff nm =
    let st = Staff_Settings Normal_Staff (name_to_id nm) 0
    in Staff st nm . Part Nothing

-- | Construct rhythmic staff.
rhythmic_staff :: Staff_Name -> [Music] -> Staff
rhythmic_staff nm =
    let st = Staff_Settings Rhythmic_Staff (name_to_id nm) 0
    in Staff st nm . Part Nothing

-- | Construct staff with text underlay.
text_staff :: Staff_Name -> String -> [Music] -> Staff
text_staff nm txt =
    let st = Staff_Settings Normal_Staff (name_to_id nm) 0
    in Staff st nm . Part (Just txt)

-- | Construct piano staff.  For two staff piano music the staffs have
--   identifiers rh and lh.
piano_staff :: Staff_Name -> [[Music]] -> Staff
piano_staff nm [rh,lh] =
    let st x = Staff_Settings Normal_Staff x 0
    in Staff_Set
       PianoStaff
       nm
       [Staff (st "rh") ("","") (Part Nothing rh)
       ,Staff (st "lh") ("","") (Part Nothing lh)]
piano_staff nm xs =
    Staff_Set PianoStaff nm (map (staff ("","")) xs)

grand_staff :: Staff_Name -> [[Music]] -> Staff
grand_staff nm = Staff_Set GrandStaff nm . map (staff ("",""))

staff_group :: Staff_Name -> [[Music]] -> Staff
staff_group nm = Staff_Set StaffGroup nm . map (staff ("",""))

rhythmic_grand_staff :: Staff_Name -> [[Music]] -> Staff
rhythmic_grand_staff nm = Staff_Set GrandStaff nm . map (rhythmic_staff ("",""))

-- | Variant with names for each staff.
grand_staff' :: Staff_Name -> [Staff_Name] -> [[Music]] -> Staff
grand_staff' nm xs ys = Staff_Set GrandStaff nm (zipWith staff xs ys)

staff_group' :: Staff_Name -> [Staff_Name] -> [[Music]] -> Staff
staff_group' nm xs ys = Staff_Set StaffGroup nm (zipWith staff xs ys)

two_part_staff :: Staff_Name -> ([Music], [Music]) -> Staff
two_part_staff nm (p0, p1) =
    let st = Staff_Settings Normal_Staff (name_to_id nm) 0
    in Staff st nm (MultipleParts [voice_one:p0
                                  ,voice_two:p1])

instr_name :: Staff_Name -> Staff -> Staff
instr_name nm pt =
    case pt of
      Staff st _ x -> Staff st nm x
      Staff_Set ty _ xs -> Staff_Set ty nm xs

resize_staff :: Int -> Staff -> Staff
resize_staff n st =
    case st of
      Staff (Staff_Settings ty i sc) nm pt ->
          Staff (Staff_Settings ty i (sc + n)) nm pt
      Staff_Set ty nm xs ->
          Staff_Set ty nm (map (resize_staff n) xs)

score :: [Staff] -> Score
score = Score default_score_settings

-- * Aliases

tempo :: Duration -> Integer -> Music
tempo = Tempo

after_grace :: Music -> Music -> Music
after_grace = AfterGrace

grace :: Music -> Music
grace = Grace

tremolo :: (Music, Music) -> Integer -> Music
tremolo = Tremolo

-- | Interior polyphony.  For two part music on one staff see
--   'two_part_staff'.
polyphony :: Music -> Music -> Music
polyphony = Polyphony

polyphony' :: [Music] -> [Music] -> Music
polyphony' x y = polyphony (mconcat x) (mconcat y)

-- * Noteheads

-- | Request cross note-heads.
cross_noteheads :: Music
cross_noteheads =
    Command (User "\\override NoteHead #'style = #'cross")

-- | Revert to standard note-heads.
revert_noteheads :: Music
revert_noteheads =
    Command (User "\\revert NoteHead #'style")

-- * Rests

-- | Joins directly adjacent rest elements.
join_rests :: [Music] -> [Music]
join_rests =
    let fn recur xs =
            case xs of
              [] -> []
              Rest d a : Rest d' a' : ys ->
                  case sum_dur d d' of
                    Nothing -> let zs = Rest d a : join_rests (Rest d' a' : ys)
                               in if recur then fn False zs else zs
                    Just d'' -> join_rests (Rest d'' (a ++ a') : ys)
              y:ys -> y : join_rests ys
    in fn True