module Music.LilyPond.Light.Output.LilyPond (ly_work
                                            ,ly_music_elem) where

import Data.List
import Music.LilyPond.Light.Model
import Music.Theory.Pitch
import Music.Theory.Duration
import Music.Theory.Key
import Text.Printf

with_brackets :: (String,String) -> [String] -> [String]
with_brackets (begin,end) xs = [begin] ++ xs ++ [end]

with_braces :: [String] -> [String]
with_braces = with_brackets ("{","}")

ly_str :: String -> String
ly_str x = "\"" ++ x ++ "\""

ly_version :: Version -> [String]
ly_version (Version v) = ["\\version", ly_str v]

ly_assign :: (String -> String) -> (String,String) -> [String]
ly_assign fn (key,value) = [key,"=",fn value]

ly_bool :: Bool -> String
ly_bool True = "##t"
ly_bool False = "##f"

ly_units :: Units -> String
ly_units x =
    case x of
      MM -> "\\mm"
      CM -> "\\cm"

ly_length :: Length -> String
ly_length (Length n x) = show n ++ ly_units x

ly_delete_nil_values :: [(String,String)] -> [(String,String)]
ly_delete_nil_values = filter (not . null . snd)

ly_paper :: Paper -> [String]
ly_paper p =
    let tw = two_sided p
        mg = if tw
             then [("binding-offset", ly_length (binding_offset p))
                  ,("inner-margin", ly_length (inner_margin p))
                  ,("outer-margin", ly_length (outer_margin p))]
             else [("left-margin", ly_length (left_margin p))
                  ,("right-margin", ly_length (right_margin p))]
        xs = [("bottom-margin", ly_length (bottom_margin p))
             ,("indent", ly_length (indent p))
             ,("paper-width", ly_length (paper_width p))
             ,("paper-height", ly_length (paper_height p))
             ,("ragged-last", ly_bool (ragged_last p))
             ,("ragged-last-bottom", ly_bool (ragged_last_bottom p))
             ,("systems-per-page", maybe "" show (systems_per_page p))
             ,("top-margin", ly_length (top_margin p))
             ,("two-sided", ly_bool tw)]
        ys = ly_delete_nil_values (xs ++ mg)
    in "\\paper" : with_braces (concatMap (ly_assign id) ys)

ly_header :: Header -> [String]
ly_header hdr =
    let xs = [("dedication", dedication hdr)
             ,("title", title hdr)
             ,("subtitle", subtitle hdr)
             ,("composer", composer hdr)
             ,("tagline", tagline hdr)]
    in "\\header" : with_braces (concatMap (ly_assign ly_str) xs)

ly_clef_t :: Clef_T -> String
ly_clef_t c =
    case c of
      Treble -> "treble"
      Alto -> "alto"
      Tenor -> "tenor"
      Bass -> "bass"
      Percussion -> "percussion"

ly_clef :: Clef_T -> Int -> String
ly_clef c o =
    let o' = case o of
               (-2) -> "_15"
               (-1) -> "_8"
               1 -> "^8"
               2 -> "^15"
               _ -> error ("ly_clef: " ++ show (c,o))
    in if o == 0
       then ly_clef_t c
       else concat ["\"", ly_clef_t c, o', "\""]

ly_note :: Note_T -> String
ly_note n =
    case n of
      C -> "c"
      D -> "d"
      E -> "e"
      F -> "f"
      G -> "g"
      A -> "a"
      B -> "b"

ly_alteration :: Alteration_T -> String
ly_alteration a =
    case a of
      DoubleFlat -> "eses"
      ThreeQuarterToneFlat -> "eseh"
      Flat -> "es"
      QuarterToneFlat -> "eh"
      Natural -> ""
      QuarterToneSharp -> "ih"
      Sharp -> "is"
      ThreeQuarterToneSharp -> "isih"
      DoubleSharp -> "isis"

ly_alteration' :: Maybe Alteration_T -> String
ly_alteration' = maybe "" ly_alteration

ly_alteration_rule :: [Annotation] -> String
ly_alteration_rule xs
    | ReminderAccidental `elem` xs = "!"
    | CautionaryAccidental `elem` xs = "?"
    | otherwise = ""

ly_octave :: Octave -> String
ly_octave o =
    case o of
      (-1) -> ",,,,"
      0 -> ",,,"
      1 -> ",,"
      2 -> ","
      3 -> ""
      4 -> "'"
      5 -> "''"
      6 -> "'''"
      7 -> "''''"
      8 -> "'''''"
      _ -> error ("ly_octave: " ++ show o)

ly_pitch :: [Annotation] -> Pitch -> String
ly_pitch xs (Pitch n a o) =
    ly_note n ++
    ly_alteration a ++
    ly_octave o ++
    ly_alteration_rule xs

ly_articulation :: Articulation_T -> String
ly_articulation a =
    case a of
      Accent -> "\\accent"
      Arpeggio -> "\\arpeggio"
      ArpeggioDown -> "\\arpeggioDown"
      ArpeggioNeutral -> "\\arpeggioNeutral"
      ArpeggioUp -> "\\arpeggioUp"
      DownBow -> "\\downbow"
      Fermata -> "\\fermata"
      Flageolet  -> "\\flageolet "
      Glissando  -> "\\glissando "
      Harmonic -> "\\harmonic"
      LaissezVibrer -> "\\laissezVibrer"
      Marcato -> "\\marcato"
      Open -> "\\open"
      Portato -> "\\portato"
      Staccato -> "\\staccato"
      StemTremolo x -> ":" ++ show x
      Stopped -> "\\stopped"
      Tenuto -> "\\tenuto"
      Trill -> "\\trill"
      UpBow -> "\\upbow"

ly_dynamic :: Dynamic_T -> String
ly_dynamic d =
    case d of
      PPPP -> "\\pppp"
      PPP -> "\\ppp"
      Pianissimo -> "\\pp"
      Piano -> "\\p"
      MezzoPiano -> "\\mp"
      MezzoForte -> "\\mf"
      Forte -> "\\f"
      Fortissimo -> "\\ff"
      FFF -> "\\fff"
      FFFF -> "\\ffff"
      FP -> "\\fp"
      SFZ -> "\\sfz"
      Begin_Crescendo -> "\\<"
      Begin_Decrescendo -> "\\>"
      End_Dynamic -> "\\!"
      Espressivo -> "\\espressivo"

ly_fraction :: (Integer,Integer) -> String
ly_fraction (n,d) = show n ++ "/" ++ show d

ly_duple :: (Show x) => (x,x) -> String
ly_duple (x,y) = "#'(" ++ show x ++ " . " ++ show y ++ ")"

-- note: the duration multiplier is *not* written
ly_duration :: Duration -> String
ly_duration = duration_to_lilypond_type

ly_phrasing :: Phrasing_T -> String
ly_phrasing p =
    case p of
      Begin_Slur -> "("
      End_Slur -> ")"
      Begin_PhrasingSlur -> "\\("
      End_PhrasingSlur -> "\\)"
      Begin_Beam -> "["
      End_Beam -> "]"
      SustainOn -> "\\sustainOn"
      SustainOff -> "\\sustainOff"

ly_annotation :: Annotation -> String
ly_annotation a =
    case a of
      Articulation x -> ly_articulation x
      Dynamic x -> ly_dynamic x
      Phrasing x -> ly_phrasing x
      Begin_Tie -> "~"
      Above -> "^"
      Below -> "_"
      Text x -> ly_str x
      CompositeAnnotation xs -> intercalate " " (map ly_annotation xs)
      ReminderAccidental -> "" -- see ly_pitch
      CautionaryAccidental -> "" -- see ly_pitch

ly_bar :: Bar_T -> String
ly_bar b =
    case b of
      NormalBarline -> "|"
      DoubleBarline -> "||"
      LeftRepeatBarline -> "|:"
      RightRepeatBarline -> ":|"
      FinalBarline -> "|."

ly_command :: Command_T -> String
ly_command c =
    case c of
      AutoBeamOff -> "\\autoBeamOff"
      Bar x -> "\\bar " ++ ly_str (ly_bar x)
      BarlineCheck -> "|\n"
      BarNumberCheck x -> "\\barNumberCheck #" ++ show x
      Break -> "\\break"
      Change x -> "\\change Staff = " ++ ly_str x
      DynamicDown -> "\\dynamicDown"
      DynamicNeutral -> "\\dynamicNeutral"
      DynamicUp -> "\\dynamicUp"
      NoBreak -> "\\noBreak"
      NoPageBreak -> "\\noPageBreak"
      Octavation x -> "\\ottava #" ++ show x
      PageBreak -> "\\pageBreak"
      Partial x -> "\\partial " ++ ly_duration x
      StemDown -> "\\stemDown"
      StemNeutral -> "\\stemNeutral"
      StemUp -> "\\stemUp"
      TupletDown -> "\\tupletDown"
      TupletNeutral -> "\\tupletNeutral"
      TupletUp -> "\\tupletUp"
      User x -> x
      VoiceOne -> "\\voiceOne"
      VoiceTwo -> "\\voiceTwo"
      VoiceThree -> "\\voiceThree"
      VoiceFour -> "\\voiceFour"

ly_key_mode :: Mode_T -> String
ly_key_mode md =
    case md of
      Major_Mode -> "\\major"
      Minor_Mode -> "\\minor"

ly_music_l :: [Music] -> [String]
ly_music_l = concatMap ly_music

ly_music :: Music -> [String]
ly_music m =
    case m of
      Note p d aa -> [ly_pitch aa p, maybe "" ly_duration d] ++
                     map ly_annotation aa
      Chord xs d aa -> with_brackets ("<",">") (ly_music_l xs) ++
                       [ly_duration d] ++
                       map ly_annotation aa
      Tremolo (x0,x1) n -> ["\\repeat", "\"tremolo\"", show n] ++
                           with_braces (ly_music x0 ++ ly_music x1)
      Rest d aa -> ["r", ly_duration d] ++ map ly_annotation aa
      MMRest i (j,k) aa -> let d = printf "R %d*%d " k (i*j)
                           in d : map ly_annotation aa
      Skip d -> ["\\skip", ly_duration d]
      Repeat n x -> ["\\repeat", "volta", show n] ++ with_braces (ly_music x)
      Tuplet o n x ->
          let (o',n') =
                  case o of
                    Normal_Tuplet -> ("\\times", ly_fraction n)
                    Scale_Durations -> ("\\scaleDurations", ly_duple n)
          in [o', n'] ++ with_braces (ly_music x)
      Grace x -> "\\grace" : with_braces (ly_music x)
      AfterGrace x0 x1 -> "\\afterGrace" : concatMap ly_music [x0, x1]
      Clef c o -> ["\\clef", ly_clef c o]
      Time n -> ["\\time", ly_fraction n]
      Key n a md -> ["\\key"
                    ,ly_note n ++ ly_alteration' a
                    ,ly_key_mode md]
      Tempo d r -> ["\\tempo", ly_duration d, "=", show r]
      Command x -> [ly_command x]
      Join xs -> concatMap ly_music xs
      Polyphony x1 x2 -> ["\\simultaneous", "{"] ++
                         with_braces (ly_music x1) ++
                         ["\\\\"] ++
                         with_braces (ly_music x2) ++
                         ["}"]
      Empty -> []

ly_staff_name :: String -> Staff_Name -> [String]
ly_staff_name p (n1,n2) =
    ["\\set", p++".instrumentName", "=", ly_str (n1++" ")
    ,"\\set", p++".shortInstrumentName", "=", ly_str (n2++" ")]

ly_staff_t :: Staff_T -> String
ly_staff_t ty =
    case ty of
      Normal_Staff -> "Staff"
      Rhythmic_Staff -> "RhythmicStaff"

ly_part :: [String] -> String -> Part -> [String]
ly_part nm i p =
    let brk = with_brackets ("<<",">>")
        mk_v xs = ["\\new"
                    ,"Voice"
                    ,"="
                    ,ly_str i] ++ with_braces (ly_music (Join xs))
        mk_txt txt = ["\\new"
                     ,"Lyrics"
                     ,"\\lyricsto"
                     ,ly_str i] ++ with_braces [" " ++ txt ++ " "]
    in case p of
         (Part Nothing xs) -> with_braces (nm ++ ly_music (Join xs))
         (Part (Just txt) xs) -> brk (nm ++ mk_v xs ++ mk_txt txt)
         (MultipleParts xs) -> brk (concatMap mk_v xs)

ly_staff_set_t :: Staff_Set_T -> String
ly_staff_set_t x =
    case x of
      ChoirStaff -> "ChoirStaff"
      GrandStaff -> "GrandStaff"
      PianoStaff -> "PianoStaff"
      StaffGroup -> "StaffGroup"
      StaffGroup_SquareBracket -> "StaffGroup"

ly_staff :: Staff -> [String]
ly_staff s =
    case s of
      Staff (Staff_Settings ty i sc) nm pt ->
          let i' = if null i then "no_id" else i
              nm' = ly_staff_name "Staff" nm
              sc' = if sc == 0
                    then ""
                    else printf " \\with { fontSize = #%d \\override StaffSymbol #'staff-space = #(magstep %d) } " sc sc
          in ["\\new"
             ,ly_staff_t ty
             ,"="
             ,ly_str i'] ++ [sc'] ++ ly_part nm' i' pt
      Staff_Set ty nm xs ->
          let ty' = ly_staff_set_t ty
              dlm = if ty == StaffGroup_SquareBracket
                    then "\\set StaffGroup.systemStartDelimiter = #'SystemStartSquare"
                    else ""
          in (["\\new"
              ,ty'
              ,"\\simultaneous"
              ] ++
              with_braces ([dlm] ++
                           ly_staff_name ty' nm ++
                           concatMap ly_staff xs))

ly_independent_time_signatures :: [String]
ly_independent_time_signatures =
    ["\\context { \\Score"
    ,"     \\remove \"Timing_translator\""
    ,"     \\remove \"Default_bar_line_engraver\""
    ,"  }"
    ,"  \\context {"
    ,"    \\Staff"
    ,"    \\consists \"Timing_translator\""
    ,"    \\consists \"Default_bar_line_engraver\""
    ,"  }"]

ly_layout :: Score_Settings -> [String]
ly_layout x =
    let mk_i nm = printf "\\context { \\%s \\consists \"Instrument_name_engraver\"}" nm
        is = unlines (map mk_i ["StaffGroup","ChoirStaff","GrandStaff"])
    in ["\\layout", "{"
       ,if independent_time_signatures x
        then unlines ly_independent_time_signatures
        else ""
       ,is
       ,"}"]

ly_score :: Score -> [String]
ly_score (Score pr xs) =
    let xs' = with_braces (concatMap ly_staff xs)
        xs'' = with_braces ("\\simultaneous" : xs' ++ ly_layout pr)
    in "\\score" : xs''

ly_work :: Work -> String
ly_work (Work v p hdr sc) =
    let xs = ly_version v ++
             ly_paper p ++
             ly_header hdr ++
             ly_score sc
    in concat (intersperse " " xs)

ly_music_elem :: Music -> String
ly_music_elem = concat . intersperse " " . ly_music