module Music.LilyPond.Light (module Music.LilyPond.Light
                            ,module Music.LilyPond.Light.Constant
                            ,module Music.LilyPond.Light.Constant.NoteName
                            ,module Music.LilyPond.Light.Model
                            ,module Music.LilyPond.Light.Output.LilyPond
                            ,module Music.Theory.Duration
                            ,module Music.Theory.Duration.Name
                            ,module Music.Theory.Key
                            ,module Music.Theory.Pitch) where

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

-- * Music category predicates

is_note :: Music -> Bool
is_note (Note _ _ _) = True
is_note _ = False

is_chord :: Music -> Bool
is_chord (Chord _ _ _) = True
is_chord _ = False

is_rest :: Music -> Bool
is_rest (Rest _ _) = True
is_rest _ = False

is_mm_rest :: Music -> Bool
is_mm_rest (MMRest _ _ _) = True
is_mm_rest _ = False

is_grace :: Music -> Bool
is_grace (Grace _) = True
is_grace _ = False

is_after_grace :: Music -> Bool
is_after_grace (AfterGrace _ _) = True
is_after_grace _ = False

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

is_clef :: Music -> Bool
is_clef (Clef _ _) = True
is_clef _ = False

is_time :: Music -> Bool
is_time (Time _) = True
is_time _ = False

is_tempo :: Music -> Bool
is_tempo (Tempo _ _) = True
is_tempo _ = False

is_barlinecheck :: Music -> Bool
is_barlinecheck (Command BarlineCheck) = True
is_barlinecheck _ = 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 (Tuplet _ _ _) = True
is_tuplet _ = False

-- * 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 x) Nothing []

-- * Rests

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

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_elements :: Measure -> [Music]
m_elements (Measure as xs) = as ++ xs

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

-- * Tuplets

-- | Apply fn to the duration of x, 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

-- | Add an annotation to 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 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))

-- | Add an annotation to music element, or error.
(&) :: 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 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 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

--  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.
(##) :: Pitch -> Duration -> Music
x ## d = Note x (Just d) []

-- | Add duration to pitch to make a note.
(#) :: 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.
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

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)

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