module Music.LilyPond.Light.Notation where

import Data.List {- base -}
import qualified Data.List.Split as Split {- split -}
import Data.Maybe {- base -}
import Data.Ratio {- base -}
import Text.Printf {- base -}

import qualified Music.Theory.Duration as T {- hmt -}
import qualified Music.Theory.Duration.Annotation as T {- hmt -}
import qualified Music.Theory.Duration.RQ as T {- hmt -}
import qualified Music.Theory.Duration.Sequence.Notate as T {- hmt -}
import qualified Music.Theory.Key as T {- hmt -}
import qualified Music.Theory.Pitch as T {- hmt -}
import qualified Music.Theory.Pitch.Spelling.Table as T {- hmt -}
import qualified Music.Theory.Time_Signature as T {- hmt -}

import Music.LilyPond.Light.Constant
import Music.LilyPond.Light.Measure
import Music.LilyPond.Light.Model
import Music.LilyPond.Light.Output.LilyPond
import Music.LilyPond.Light.Paper

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

-- * Duration

-- | If 'Music' is a 'Note', 'Chord' or 'Rest' give duration, else 'Nothing'.
music_immediate_duration :: Music -> Maybe T.Duration
music_immediate_duration m =
    case m of
      Note _ d _ -> d
      Chord _ d _ -> Just d
      Rest _ d _ -> Just d
      _ -> Nothing

-- * 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 :: (T.Octave, T.PitchClass) -> Music
octpc_to_note x = Note (T.octpc_to_pitch T.pc_spell_ks x) Nothing []

-- * Rests

-- | Construct normal rest.
rest :: T.Duration -> Music
rest x = Rest Normal_Rest x []

-- | Construct spacer rest.
spacer_rest :: T.Duration -> Music
spacer_rest x = Rest Spacer_Rest x []

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

-- | Non-printing variant of 'rest'.
skip :: T.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 = T.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 :: (T.Duration -> T.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 ty d a -> Rest ty (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 { T.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 { T.multiplier = d%n }
    in Tuplet Scale_Durations (n,d) . mconcat . map (edit_dur fn)

-- * Time signatures

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

-- | Allow proper auto-indenting of multiple measures with the same
--   time signature.
with_time_signature :: T.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) []

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

-- | Hide metronome mark if 'False'.
mm_stencil :: Bool -> Music
mm_stencil x =
    let c = "\\override Score.MetronomeMark #'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 :: T.Key -> Music
key (n,a,md) = Key n (Just a) md

-- * 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 :: (T.Octave -> T.Octave) -> Music -> Music
note_edit_octave fn m =
    case m of
      Note (T.Pitch n a o) d xs -> Note (T.Pitch n a (fn o)) d xs
      _ -> m

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

-- * Duration

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

-- | If there is a 'T.Tie_Left', then clear the appropriate annotations.
-- (Actually just all...)
clear_l_ann :: [T.D_Annotation] -> [Annotation] -> [Annotation]
clear_l_ann d_a m_a = if any (== T.Tie_Left) d_a then [] else m_a

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

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

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

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

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

-- * Chords

-- | Construct chord from 'Pitch' elements.
chd_p_ann :: [T.Pitch] -> [[Annotation]] -> T.Duration -> Music
chd_p_ann xs an d =
    let f x a = Note x Nothing a
    in case xs of
         [] -> error "chd_p_ann: null elements"
         _ -> Chord (zipWith f xs an) d []

-- | Construct chord from 'Pitch' elements.
chd_p :: [T.Pitch] -> T.Duration -> Music
chd_p xs = chd_p_ann xs (repeat [])

-- | Construct chord from 'Music' elements.
chd :: [Music] -> T.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 (for cross staff notation).
change :: String -> Music
change x = Command (Change x) []

-- | Indicate initial partial measure.
partial :: T.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

staff_line_count :: Int -> Music
staff_line_count n =
    let x = "\\override Staff.StaffSymbol.line-count = #" ++ show n
    in Command (User x) []

staff' :: Staff_T -> Staff_Name -> [Music] -> Staff
staff' ty nm =
    let st = Staff_Settings ty (name_to_id nm) 0
    in Staff st nm . Part Nothing Nothing

-- | Construct staff.
staff :: Staff_Name -> [Music] -> Staff
staff = staff' Normal_Staff

-- | Construct rhythmic staff.
rhythmic_staff :: Staff_Name -> [Music] -> Staff
rhythmic_staff = staff' Rhythmic_Staff

-- | 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 Nothing (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 Nothing rh)
             ,Staff (st "lh") ("","") (Part Nothing 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.
staff_set :: (Staff_Set_T,Staff_T) -> Staff_Name -> [Staff_Name] -> [[Music]] -> Staff
staff_set (set_ty,stf_ty) nm xs ys = Staff_Set set_ty nm (zipWith (staff' stf_ty) xs ys)

grand_staff' :: Staff_Name -> [Staff_Name] -> [[Music]] -> Staff
grand_staff' = staff_set (GrandStaff,Normal_Staff)

staff_group' :: Staff_Name -> [Staff_Name] -> [[Music]] -> Staff
staff_group' = staff_set (StaffGroup,Normal_Staff)

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.  Type is adopted from the
-- right when joining.
join_rests :: [Music] -> [Music]
join_rests =
    let fn recur xs =
            case xs of
              [] -> []
              Rest ty d a : Rest ty' d' a' : ys ->
                  case T.sum_dur d d' of
                    Nothing -> let zs = Rest ty d a : join_rests (Rest ty' d' a' : ys)
                               in if recur then fn False zs else zs
                    Just d'' -> join_rests (Rest ty' 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 = (T.Duration_A,x) -> Music

{- | Given 'DA_F' transform, transform set of ascribed 'Duration_A'
values to 'Music'.

> import Music.Theory.Duration.Sequence.Notate as T
> import Music.Theory.Duration.RQ.Tied as T
> import Music.Theory.Pitch.Name as T
> import Music.LilyPond.Light.Output.LilyPond as L

> let {Right d = T.m_notate True [[(2/3,_f),(1/3,_t)],[(1,_t)],[(1,_f)]]
>     ;jn (i,j) = j ##@ i
>     ;n = T.ascribe d [c4,d4]
>     ;r = "\\times 2/3 { c' 4 d' 8 ~ } d' 4 ~ d' 4"}
> in L.ly_music_elem (Join (da_to_music jn n)) == r

-}
da_to_music :: DA_F t -> [(T.Duration_A,t)] -> [Music]
da_to_music fn x =
    let g = T.da_group_tuplets_nn (map fst x)
        g' = T.nn_reshape (,) g (map snd x)
        tr el = case el of
                 Left i -> fn i
                 Right y -> let (y0,_):_ = y
                                (n,d,_) = fromJust (T.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 [T.Time_Signature] -> [[(T.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

{- | 'da_to_measures' of 'notate_mm_ascribe'.

> import Music.Theory.Pitch.Name as T
> import Music.LilyPond.Light.Output.LilyPond as L

> let {jn (i,j) = j ##@ i
>     ;[Measure _ m] = rq_to_measures 4 jn [] [(3,4)] Nothing [2/3,1/3 + 2] [c4,d4]
>     ;r = "\\times 2/3 { c' 4 d' 8 ~ } d' 2"}
> in L.ly_music_elem (Join m) == r

-}
rq_to_measures :: (Show x) => Int -> DA_F x -> [T.Simplify_T] -> [T.Time_Signature] -> Maybe [[T.RQ]] -> [T.RQ] -> [x] -> [Measure]
rq_to_measures limit fn r ts rqp rq x =
    let da = T.notate_mm_ascribe_err limit r ts rqp rq x
    in da_to_measures fn (Just ts) da

-- * Fragment

-- | Make a fragment (possibly multiple staffs) from '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 (grand_staff ("","") m)

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

-- * Stem

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

-- * Text

-- | Make text annotations respace music to avoid vertical displacement.
text_length_on,text_length_off :: Music
text_length_on = Command (User "\\textLengthOn") []
text_length_off = Command (User "\\textLengthOff") []

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 (remove) redundant (repeated, duplicated) 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

-- | Group measures per system.
mm_measures_per_system :: [Int] -> [Measure] -> [Measure]
mm_measures_per_system n mm =
  let f (m0:l) = m_annotate_pre system_break m0 : l
      f [] = error "mm_measures_per_system"
  in case Split.splitPlaces n mm of
       g0:l -> concat (g0 : map f l)
       _ -> mm

-- | Prepend 'system_break' at every nth measure.
mm_measures_per_system_eq :: Int -> [Measure] -> [Measure]
mm_measures_per_system_eq n =
    let f k m = if k /= 0 && k `mod` n == 0
                then m_annotate_pre system_break m
                else m
    in zipWith f [0..]

-- * Rehearsal marks

default_rehearsal_mark :: Music
default_rehearsal_mark = Command (Rehearsal_Mark Nothing) []