module Music.LilyPond.Light.Output.LilyPond
    (ly_work
    ,ly_fragment
    ,ly_music_elem
    ,ly_process,ly_process_cwd
    ,Lilypond(..)) where

import Data.Char
import Music.LilyPond.Light.Model
import qualified Music.Theory.Clef as C {- hmt -}
import Music.Theory.Pitch
import Music.Theory.Duration
import Music.Theory.Dynamic_Mark
import Music.Theory.Key
import System.Directory {- directory -}
import System.Exit
import System.FilePath {- filepath -}
import System.Process {- process -}
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_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))
             ,("ragged-right", ly_bool (ragged_right p))
             ,("systems-per-page", maybe "" show (systems_per_page p))
             ,("top-margin", ly_length (top_margin p))
             ,("two-sided", ly_bool tw)
             ,("print-page-number", ly_bool (print_page_number p))]
        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 :: C.Clef_T -> String
ly_clef_t c =
    case c of
      C.Treble -> "treble"
      C.Alto -> "alto"
      C.Tenor -> "tenor"
      C.Bass -> "bass"
      C.Percussion -> "percussion"

ly_clef :: C.Clef Int -> String
ly_clef (C.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 = map toLower . show

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

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 ++
    alteration_ly_name 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_hairpin_t :: Hairpin_T -> String
ly_hairpin_t h =
    case h of
      Crescendo -> "\\<"
      Diminuendo -> "\\>"
      End_Hairpin -> "\\!"

ly_dynamic :: Dynamic_T -> String
ly_dynamic d =
    case d of
      Dynamic_Mark m -> '\\' : map toLower (show m)
      Hairpin h -> ly_hairpin_t h
      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 -> "~"
      Place_Above -> "^"
      Place_Below -> "_"
      Text_Mark -> "\\mark"
      Text Text_Plain x -> ly_str x
      Text Text_Markup x -> "\\markup {" ++ x ++ "}"
      CompositeAnnotation xs -> unwords (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 aa -> ["\\skip", ly_duration d] ++ map ly_annotation aa
      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 -> ["\\clef", ly_clef c]
      Time n -> ["\\time", ly_fraction n]
      Key n a md -> ["\\key"
                    ,ly_note n ++ ly_alteration' a
                    ,ly_key_mode md]
      Tempo d r ->
          let r' = floor r :: Integer
          in ["\\tempo", ly_duration d, "=", show r']
      Command x aa -> ly_command x : map ly_annotation aa
      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_remove_empty_staves :: Bool -> [String]
ly_remove_empty_staves g =
    ["\\context {"
    ,"  \\Staff \\RemoveEmptyStaves"
    ,if g
     then "   \\override VerticalAxisGroup #'remove-first = ##t"
     else ""
    ,"}"]

ly_layout :: Score_Settings -> [String]
ly_layout x =
    let mk_i = printf "\\context { \\%s \\consists \"Instrument_name_engraver\"}"
        is = unlines (map mk_i ["StaffGroup","ChoirStaff","GrandStaff"])
    in ["\\layout", "{"
       ,if independent_time_signatures x
        then unlines ly_independent_time_signatures
        else ""
       ,if remove_empty_staves x
        then unlines (ly_remove_empty_staves (remove_empty_staves_first_system x))
        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''

-- | Translate 'Work' to lilypond source code.
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 unwords xs

-- | Translate 'Music' element to lilypond source code.
--
-- > import Music.LilyPond.Light
-- > import Music.Theory.Duration.Name.Abbreviation
-- > ly_music_elem (Join [c4#q',e4#h]) == "c' 4. e' 2"
ly_music_elem :: Music -> String
ly_music_elem = unwords . ly_music

ly_fragment :: Fragment -> String
ly_fragment (Fragment v p m) =
    unlines (ly_version v ++
             ly_paper p ++
             ly_header default_header ++
             with_braces [ly_music_elem m])

class Lilypond a where ly_notate :: a -> String
instance Lilypond Score where ly_notate = unlines . ly_score
instance Lilypond Work where ly_notate = ly_work
instance Lilypond Fragment where ly_notate = ly_fragment

-- | Notate 'Lilypond' value, write to file, and run @lilypond@ to
-- generate output in 'Format'.
ly_process :: Lilypond a => FilePath -> Format -> String -> a -> IO ExitCode
ly_process dir fmt nm ly = do
  let fmt' = map toLower (show fmt)
      o_fn = dir </> nm
      ly_fn = o_fn <.> "ly"
      cmd = printf "lilypond --%s -o %s %s" fmt' o_fn ly_fn
  writeFile ly_fn (ly_notate ly)
  system cmd

-- | Variant of 'ly_process' using current working directory.
ly_process_cwd :: Lilypond a => Format -> String -> a -> IO ExitCode
ly_process_cwd fmt nm ly = do
  d <- getCurrentDirectory
  ly_process d fmt nm ly