Notation.hs

module Music.LilyPond.Light.Notation where

import Data.List
import Data.Maybe
import Data.Monoid
import Data.Ratio
import Music.LilyPond.Light.Constant
import Music.LilyPond.Light.Measure
import Music.LilyPond.Light.Model
import Music.LilyPond.Light.Output.LilyPond
import Music.Theory.Duration {- hmt -}
import Music.Theory.Duration.Annotation
import Music.Theory.Key
import Music.Theory.Pitch
import Music.Theory.Pitch.Spelling
import Music.Theory.Time_Signature
import Text.Printf

-- * 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_skip :: Music -> Bool
is_skip = is_music_c Skip_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_command :: Music -> Bool
is_command = is_music_c Command_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

-- | 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.
rest :: Duration -> Music
rest x = Rest x []

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

-- | Non-printing variant of 'rest'.
skip :: Duration -> Music
skip x = Skip x []

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

-- | Like 'empty_measure', but with an invisible rest.
null_measure :: Integer -> Integer -> Music
null_measure n d =
    let x = Duration d 0 1
        l = [bar_line_check]
    in mconcat (map (\i -> Skip i []) (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]

-- * 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 a -> Skip (fn d) a
      _ -> 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 :: Time_Signature -> Music
time_signature = Time

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

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

-- | 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) []

ts_stencil :: Bool -> Music
ts_stencil x =
    let c = "\\override Staff.TimeSignature #'stencil = " ++ ly_bool x
    in Command (User c) []

ts_transparent :: Bool -> Music
ts_transparent x =
    let c = "\\override Staff.TimeSignature #'transparent = " ++ ly_bool x
    in Command (User c) []

ts_all_invisible :: Music
ts_all_invisible =
    let c = "\\override Staff.TimeSignature #'break-visibility = #all-invisible"
    in Command (User c) []

-- * Key signatures

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

-- * Repetition

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

-- * 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)

-- * Duration

-- > tie_r_ann [Tie_Right] == [Begin_Tie]
tie_r_ann :: [D_Annotation] -> [Annotation]
tie_r_ann a = if any (== Tie_Right) a then [Begin_Tie] else []

-- | Rest of  'Duration_A'.
da_rest :: Duration_A -> Music
da_rest (d,_) = Rest d []

-- | Add 'Duration_A' to 'Pitch' to make a @Note@ 'Music' element.
(##@) :: Pitch -> Duration_A -> Music
x ##@ (d,a) = Note x (Just d) (tie_r_ann a)

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

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

-- | Add 'Duration' to either a @Note@ or @Chord@ 'Music' element.
(#) :: Music -> Duration -> Music
x # d = x #@ (d,[])

-- * Chords

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

chd :: [Music] -> Duration -> Music
chd xs d =
    case xs of
      [] -> error "chd: null elements"
      _ -> 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 n = Command (BarNumberCheck n) []

-- | Switch bar numbering visibility.
bar_numbering :: Bool -> Music
bar_numbering x =
    let r = if x then "#(#t #t #t)" else "#(#f #f #f)"
        s = "\\override Score.BarNumber #'break-visibility = #'" ++ r
    in Command (User s) []

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

-- | Indicate initial partial measure.
partial :: Duration -> Music
partial d = Command (Partial d) []

-- | 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) []

-- | Set or unset the @minimum-length@ hairpin attribute.
hairpin_minimum_length :: Maybe Int -> Music
hairpin_minimum_length x =
    let c = case x of
              Nothing -> "\\revert Hairpin #'minimum-length"
              Just n -> "\\override Hairpin #'minimum-length = #" ++ show n
    in Command (User c) []

-- * Staff and Parts

set_8va_notation :: Music
set_8va_notation = Command (User "\\set Staff.ottavation = #\"8\"") []

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 xs =
    case xs of
      [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)]
      _ -> 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

-- | 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)

-- * 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

-- * 'Duration_A' functions

-- | Transform ascribed 'Duration_A' value to 'Music'.
type DA_F x = (Duration_A,x) -> Music

-- | Given 'DA_F' transform, transform set of ascribed 'Duration_A'
-- values to 'Music'.
--
-- > import Music.Theory.Duration.Sequence.Notate
-- > import Music.Theory.Duration.RQ.Tied
-- > import Music.Theory.Pitch.Name
-- > import Music.LilyPond.Light.Output.LilyPond
--
-- > let {Just d = m_notate True [[(2/3,_f),(1/3,_t)],[(1,_t)],[(1,_f)]]
-- >     ;jn (i,j) = j ##@ i
-- >     ;n = ascribe d [c4,d4]
-- >     ;r = "\\times 2/3 { c' 4 d' 8 ~ } d' 4 ~ d' 4"}
-- > in ly_music_elem (Join (da_to_music jn n)) == r
da_to_music :: DA_F t -> [(Duration_A,t)] -> [Music]
da_to_music fn x =
    let g = da_group_tuplets_nn (map fst x)
        g' = nn_reshape (,) g (map snd x)
        tr el = case el of
                 Left i -> fn i
                 Right y -> let (y0,_):_ = y
                                (n,d,_) = fromJust (da_begin_tuplet y0)
                            in Tuplet Normal_Tuplet (d,n) (Join (map fn y))
    in map tr g'

-- | Variant of 'da_to_music' that operates on sets of measures.
da_to_measures :: DA_F x -> Maybe [Time_Signature] -> [[(Duration_A,x)]] -> [Measure]
da_to_measures fn m_t x =
    let m = map (da_to_music fn) x
        jn i = Measure [i]
    in case m_t of
         Just t -> zipWith jn (map Time t) m
         Nothing -> map (Measure []) m

-- * Fragment

-- | Make a fragment from a list of 'Music' elements.  Width and
-- height are in millimeters.
mk_fragment :: (Double, Double) -> [Music] -> Fragment
mk_fragment (w,h) m =
    let pr = mk_fragment_paper w h
    in Fragment default_version pr (Join m)

-- | 'Measure' variant of 'mk_fragment'.
mk_fragment_mm :: (Double, Double) -> [Measure] -> Fragment
mk_fragment_mm d = mk_fragment d . mm_elements

-- * Stem

stem_transparent :: Bool -> Music
stem_transparent x =
    let c = "\\override Stem #'transparent = " ++ ly_bool x
    in Command (User c) []

-- * Text

text_length_on :: Music
text_length_on = Command (User "\\textLengthOn") []

text_outside_staff_priority :: Maybe Double -> Music
text_outside_staff_priority x =
    let pr = case x of
              Nothing -> ly_bool False
              Just n -> '#' : show n
        s = "\\override TextScript #'outside-staff-priority = " ++ pr
    in Command (User s) []

text_extra_spacing_width :: (Double,Double) -> Music
text_extra_spacing_width (i,j) =
    let t = "\\override TextScript #'extra-spacing-width = #'(%f . %f)"
        s = printf t i j
    in Command (User s) []

-- * Measure operations

-- | Delete redundant (repeated) time signatures.
--
-- > let mm = [Measure [Time (3,4)] [],Measure [Time (3,4)] []]
-- > in mm_delete_redundant_ts mm == [Measure [Time (3,4)] [],Measure [] []]
mm_delete_redundant_ts :: [Measure] -> [Measure]
mm_delete_redundant_ts =
    let f st m = let Measure a n = m
                     ts = find is_time a
                 in case (st,ts) of
                      (Just p,Just q) -> if p == q
                                         then (st,Measure (delete q a) n)
                                         else (ts,m)
                      (_,Just _) -> (ts,m)
                      _ -> (st,m)
    in snd . mapAccumL f Nothing