module Music.Typesetting.Output.MusicXML where

import Data.Char
import Data.List
import Data.Maybe
import Data.Ratio
import Music.Typesetting.Model
import Music.Typesetting.Output.MusicXML.Binding
import qualified Music.Theory.Clef as T {- hmt -}
import qualified Music.Theory.Duration as T
import qualified Music.Theory.Duration.RQ as T
import qualified Music.Theory.Dynamic_Mark as T
import qualified Music.Theory.Key as T
import qualified Music.Theory.Pitch as T
import qualified Music.Theory.Time_Signature as T
import qualified Music.Theory.Tempo_Marking as T
import qualified Text.XML.Light as X {- xml -}

x_clef_t :: T.Clef_T -> (String,Integer)
x_clef_t c =
    case c of
      T.Treble -> ("G",2)
      T.Alto -> ("C",3)
      T.Tenor -> ("C",4)
      T.Bass -> ("F",4)
      T.Percussion -> ("percussion",3)

x_clef :: T.Clef Integer -> Integer -> X.Content
x_clef (T.Clef c i) n =
    let (s,l) = x_clef_t c
        a = [number (show n)]
    in clef a [sign [] [cdata s]
              ,line [] [cdata (show l)]
              ,clef_octave_change [] [cdata (show i)]]

key_mode_t :: T.Mode_T -> String
key_mode_t md =
    case md of
      T.Major_Mode -> "major"
      T.Minor_Mode -> "minor"

x_key :: (T.Note_T,Maybe T.Alteration_T,T.Mode_T) -> X.Content
x_key (n,a,m) =
    let a' = fromMaybe T.Natural a
    in key [] [fifths [] [cdata (show (T.key_fifths (n,a',m)))]
              ,mode [] [cdata (key_mode_t m)]]

x_time :: T.Time_Signature -> X.Content
x_time (n,d) = time [] [beats [] [cdata (show n)]
                       ,beat_type [] [cdata (show d)]]

x_pitch :: T.Pitch -> X.Content
x_pitch (T.Pitch n a o) =
    pitch [] [step [] [cdata (show n)]
             ,alter [] [cdata (show (T.alteration_to_fdiff a::Double))]
             ,octave [] [cdata (show o)]]

x_alteration_t :: T.Alteration_T -> String
x_alteration_t x =
    case x of
      T.DoubleFlat -> "double-flat"
      T.ThreeQuarterToneFlat -> "three-quarters-flat"
      T.Flat -> "flat"
      T.QuarterToneFlat -> "quarter-flat"
      T.Natural -> "natural"
      T.QuarterToneSharp -> "quarter-sharp"
      T.Sharp -> "sharp"
      T.ThreeQuarterToneSharp -> "three-quarters-sharp"
      T.DoubleSharp -> "double-sharp"

x_pitch_accidental :: T.Pitch -> X.Content
x_pitch_accidental (T.Pitch _ a _) =
    accidental [] [cdata (x_alteration_t a)]

x_multiplier :: Rational -> X.Content
x_multiplier x =
    let (n,d) = (numerator x,denominator x)
    in time_modification [] [actual_notes [] [cdata (show d)]
                            ,normal_notes [] [cdata (show n)]]

x_divisions :: Integer
x_divisions = 5 * 7 * 8 * 9 * 11 * 12

duration_rq_to_dv :: Rational -> Integer
duration_rq_to_dv x =
    let n = x * toRational x_divisions
    in if denominator n == 1
       then numerator n
       else error ("duration_rq_to_dv: non integer duration" ++ show n)

-- due to absurd ordering requirements the duration information
-- is collected in three parts (duration,type+dots,multipler)
x_duration :: T.Duration -> (X.Content,[X.Content],Maybe X.Content)
x_duration d =
    let (T.Duration dv dt m) = d
        n = duration_rq_to_dv (T.duration_to_rq d)
        ty = T.whole_note_division_to_musicxml_type dv
        dt' = genericReplicate dt (dot [])
        m' = if m == 1 then Nothing else Just (x_multiplier m)
    in (duration [] [cdata (show n)]
       ,type_E [] [cdata ty] : dt'
       ,m')

x_tuplet_t_elem :: (Integer, T.Duration) -> [X.Content]
x_tuplet_t_elem (n,d) =
    let (T.Duration dv dt _) = d
        ty = T.whole_note_division_to_musicxml_type dv
        dt' = genericReplicate dt (tuplet_dot [])
    in [tuplet_number [] [cdata (show n)]
       ,tuplet_type [] [cdata ty]] ++ dt'

x_tuplet_t :: Maybe Tuplet_T -> [X.Content]
x_tuplet_t t =
    case t of
      Nothing -> []
      Just (an,ad,nn,nd) ->
          let a = x_tuplet_t_elem (an,ad)
              n = x_tuplet_t_elem (nn,nd)
          in [tuplet_actual [] a,tuplet_normal [] n]

x_ornament_t :: Ornament_T -> X.Content
x_ornament_t = mk_empty_elem_no_attr . map c_hs_to_xml . show

x_ornament :: N_Annotation -> Maybe X.Content
x_ornament x =
    case x of
      N_Ornament d -> Just (x_ornament_t d)
      N_Stem_Tremolo i -> Just (tremolo [type_A "single"] [cdata (show i)])
      _ -> Nothing

x_ornaments :: [N_Annotation] -> Maybe X.Content
x_ornaments xs =
    case mapMaybe x_ornament xs of
       [] -> Nothing
       xs' -> Just (ornaments [] xs')

x_font_style :: Font_Style_T -> String
x_font_style st =
    case st of
      Font_Style_Normal -> "normal"
      Font_Style_Italic -> "italic"

x_font_weight :: Font_Weight_T -> String
x_font_weight wh =
    case wh of
      Font_Weight_Normal -> "normal"
      Font_Weight_Bold -> "bold"

x_font_attr :: Maybe Font_T -> [X.Attr]
x_font_attr =
    let f (Font fm st sz wh) =
            [font_family fm
            ,font_style (x_font_style st)
            ,font_size (show sz)
            ,font_weight (x_font_weight wh)]
    in maybe [] f

x_technical_el :: N_Annotation -> Maybe X.Content
x_technical_el x =
    case x of
      N_Technical t ->
          Just (case t of
                  Up_Bow -> up_bow []
                  Down_Bow -> down_bow []
                  Open_String -> open_string []
                  Stopped -> stopped []
                  Snap_Pizzicato -> snap_pizzicato []
                  Harmonic Artifical_Harmonic -> harmonic [] [artificial []]
                  Harmonic Natural_Harmonic -> harmonic [] [natural []]
                  Other_Technical f s -> other_technical (x_font_attr f) s
               )
      _ -> Nothing

x_technical :: [N_Annotation] -> Maybe X.Content
x_technical xs =
    case mapMaybe x_technical_el xs of
       [] -> Nothing
       xs' -> Just (technical [] xs')

x_placement_t :: Placement_T -> X.Attr
x_placement_t = placement . map toLower . show

c_underscore_to_hyphen :: Char -> Char
c_underscore_to_hyphen x = if x == '_' then '-' else x

c_hs_to_xml :: Char -> Char
c_hs_to_xml = toLower . c_underscore_to_hyphen

x_articulation_t :: Articulation_T -> X.Content
x_articulation_t = mk_empty_elem_no_attr . map c_hs_to_xml . show

x_articulation :: N_Annotation -> Maybe X.Content
x_articulation x =
    case x of
      N_Articulation d -> Just (x_articulation_t d)
      _ -> Nothing

x_articulations :: [N_Annotation] -> Maybe X.Content
x_articulations xs =
    case mapMaybe x_articulation xs of
       [] -> Nothing
       xs' -> Just (articulations [] xs')

x_dynamic_mark_t :: T.Dynamic_Mark_T -> X.Content
x_dynamic_mark_t = mk_empty_elem_no_attr . map toLower . show

{-
x_dynamic_mark :: N_Annotation -> Maybe X.Content
x_dynamic_mark x =
    case x of
      N_Dynamic_Mark d -> Just (x_dynamic_mark_t d)
      _ -> Nothing

x_dynamics :: [N_Annotation] -> Maybe X.Content
x_dynamics xs =
    case mapMaybe x_dynamic_mark xs of
       [] -> Nothing
       xs' -> Just (dynamics [x_placement_t Below] xs')
-}

x_notation :: N_Annotation -> Maybe X.Content
x_notation x =
    case x of
      N_Begin_Tied -> Just (tied [type_A "start"])
      N_End_Tied -> Just (tied [type_A "stop"])
      N_Begin_Slur -> Just (slur [type_A "start"])
      N_End_Slur -> Just (slur [type_A "stop"])
      N_Begin_Tuplet t -> Just (tuplet [type_A "start"] (x_tuplet_t t))
      N_End_Tuplet -> Just (tuplet [type_A "stop"] [])
      N_Begin_Glissando -> Just (glissando [type_A "start"] [])
      N_End_Glissando -> Just (glissando [type_A "stop"] [])
      N_Begin_Slide -> Just (slide [type_A "start"] [])
      N_End_Slide -> Just (slide [type_A "stop"] [])
      N_Fermata -> Just (fermata [] [])
      N_Arpeggiate -> Just (arpeggiate [])
      _ -> Nothing

x_notations :: [N_Annotation] -> Maybe X.Content
x_notations xs =
    let n = mapMaybe x_notation xs
        o = catMaybes [x_ornaments xs
                      ,x_technical xs
                      ,x_articulations xs
                      {-,x_dynamics xs-}]
    in case n ++ o of
         [] -> Nothing
         xs' -> Just (notations [] xs')

x_note_elem :: N_Annotation -> Maybe X.Content
x_note_elem x =
    case x of
      N_Pitch p -> Just (x_pitch p)
      N_Rest -> Just (rest [] [])
      N_Grace -> Just (grace [])
      N_Chord -> Just (chord [])
      _ -> Nothing

x_metronome :: T.Tempo_Marking -> X.Content
x_metronome (d,n) =
    let (T.Duration dv dt _) = d
        ty = T.whole_note_division_to_musicxml_type dv
        dt' = genericReplicate dt (dot [])
        n' = per_minute [] [cdata (show n)]
    in metronome [] ((beat_unit [] [cdata ty] : dt') ++ [n'])

x_pedal_type :: Pedal_T -> X.Attr
x_pedal_type t =
    let n = case t of
              Pedal_Start -> "start"
              Pedal_Stop -> "stop"
              Pedal_Continue -> "continue"
              Pedal_Change -> "change"
    in type_A n

dynamic_mark_to_sound_value :: T.Dynamic_Mark_T -> Maybe Double
dynamic_mark_to_sound_value = fmap (* (10 / 9)) . T.dynamic_mark_midi

x_direction :: Direction_T -> Maybe X.Content
x_direction x =
    case x of
      D_Dynamic_Mark mk ->
          let ty = direction_type [] [dynamics [] [x_dynamic_mark_t mk]]
              sn = fmap (x_sound . Sound_Dynamics) (dynamic_mark_to_sound_value mk)
              el = maybe [ty] ((ty :) . return) sn
          in Just (direction [x_placement_t Below] el)
      D_Hairpin T.Crescendo ->
          let ty = direction_type [] [wedge [type_A "crescendo"]]
          in Just (direction [x_placement_t Below] [ty])
      D_Hairpin T.Diminuendo ->
          let ty = direction_type [] [wedge [type_A "diminuendo"]]
          in Just (direction [x_placement_t Below] [ty])
      D_Hairpin T.End_Hairpin ->
          let ty = direction_type [] [wedge [type_A "stop"]]
          in Just (direction [x_placement_t Below] [ty])
      D_Laissez_Vibrer ->
          let ty = direction_type [] [words' [] [cdata "l.v."]]
          in Just (direction [x_placement_t Above] [ty])
      D_Pedal pt _ _ ->
          let ty = direction_type [] [pedal [x_pedal_type pt]]
          in Just (direction [x_placement_t Below] [ty])
      D_Tempo_Marking m ->
          let ty = direction_type [] [x_metronome m]
          in Just (direction [x_placement_t Above] [ty])

x_n_direction :: N_Annotation -> Maybe X.Content
x_n_direction x =
    case x of
      N_Direction d -> x_direction d
      _ -> Nothing

x_m_direction :: M_Annotation -> Maybe X.Content
x_m_direction x =
    case x of
      M_Direction d -> x_direction d
      _ -> Nothing

x_sound :: Sound_T -> X.Content
x_sound s =
    case s of
      Sound_Tempo n -> sound [tempo (show n)] []
      Sound_Dynamics n -> sound [dynamics' (show n)] []

{-
x_n_sound :: N_Annotation -> Maybe X.Content
x_n_sound x =
    case x of
      N_Sound s -> Just (x_sound s)
      _ -> Nothing
-}

x_accidental :: [N_Annotation] -> [X.Content]
x_accidental =
    let fn x = case x of
                 N_Pitch p -> Just (x_pitch_accidental p)
                 _ -> Nothing
    in mapMaybe fn

x_voice :: [N_Annotation] -> [X.Content]
x_voice =
    let fn x = case x of
                 N_Voice i -> Just (voice [] [cdata (show i)])
                 _ -> Nothing
    in mapMaybe fn

x_notehead_t :: Notehead_T -> [X.Content]
x_notehead_t h =
    let s = case h of
              Notehead_Triangle -> "triangle"
              Notehead_Diamond -> "diamond"
              Notehead_Square -> "square"
              Notehead_Cross -> "cross"
    in [cdata s]

x_notehead :: [N_Annotation] -> [X.Content]
x_notehead =
    let fn x = case x of
                 N_Notehead h -> Just (notehead [] (x_notehead_t h))
                 _ -> Nothing
    in mapMaybe fn

x_staff :: [N_Annotation] -> [X.Content]
x_staff =
    let fn x = case x of
                 N_Staff n -> Just (staff [] n)
                 _ -> Nothing
    in mapMaybe fn

x_beam_t :: Beam_T -> [X.Content]
x_beam_t b =
    let s = case b of
              Beam_Begin -> "begin"
              Beam_Continue -> "continue"
              Beam_End -> "end"
    in [cdata s]

x_beam :: [N_Annotation] -> [X.Content]
x_beam =
    let fn x = case x of
                 N_Beam i j -> Just (beam [number (show i)] (x_beam_t j))
                 _ -> Nothing
    in mapMaybe fn

x_note :: Note -> [X.Content]
x_note (Note d xs) =
    let (d',ty_dt,m) = x_duration d
        xs' = sort xs
        es = mapMaybe x_note_elem xs'
        nt = catMaybes [x_notations xs]
        dr = mapMaybe x_n_direction xs
        --sn = mapMaybe x_n_sound xs
        ac = x_accidental xs
        vc = x_voice xs
        m' = maybe [] return m
        bm = x_beam xs
        nh = x_notehead xs
        st = x_staff xs
        n = note [] (concat [es,[d'],vc,ty_dt,ac,m',nh,st,bm,nt])
    in dr ++ {- sn ++ -} [n]

x_attribute :: M_Annotation -> Maybe X.Content
x_attribute x =
    case x of
      M_Division i -> Just (divisions [] [cdata (show i)])
      M_Clef c n -> Just (x_clef c n)
      M_Key n a m -> Just (x_key (n,a,m))
      M_Time_Signature i -> Just (x_time i)
      M_Staves n -> Just (staves [] n)
      M_Direction _ -> Nothing

x_attributes :: [M_Annotation] -> X.Content
x_attributes xs = attributes [] (mapMaybe x_attribute xs)

x_measure :: (Integer,Measure) -> X.Content
x_measure (i,Measure as ns) =
    let as' = sort as
        a = x_attributes as'
        dr = mapMaybe x_m_direction as'
        ns' = concatMap x_note ns
    in measure [number (show i)] (a : dr ++ ns')

set_divisions :: [Measure] -> [Measure]
set_divisions xs =
    case xs of
      [] -> error "hts: set_divisions: no measures?"
      Measure as ms : xs' -> Measure (M_Division x_divisions : as) ms : xs'

x_part_name :: Name -> [X.Content]
x_part_name (nm,ab) = [part_name [] [cdata nm]
                      ,part_abbreviation [] [cdata ab]]

x_p_annotation :: P_Annotation -> [X.Content]
x_p_annotation x =
    case x of
      P_Name nm -> x_part_name nm

x_score_part :: Part -> X.Content
x_score_part p =
    case p of
      (Part (Just i) as _) ->
          let as' = concatMap x_p_annotation as
              i' = 'P' : show i
          in score_part [id_A i'] as'
      _ -> error "x_score_part: no ID or GROUP"

x_group_name :: Name -> [X.Content]
x_group_name (nm,ab) = [group_name [] [cdata nm]
                       ,group_abbreviation [] [cdata ab]]

x_group_symbol_t :: Group_Symbol_T -> X.Content
x_group_symbol_t x =
    let x' = map toLower (show x)
    in group_symbol [] [cdata x']

x_g_annotation :: G_Annotation -> [X.Content]
x_g_annotation x =
    case x of
      G_Name nm -> x_group_name nm
      G_Symbol sy -> [x_group_symbol_t sy]

x_part_group :: Part -> [X.Content]
x_part_group g =
    case g of
      Group (Just i) as ps ->
          let as' = concatMap x_g_annotation as
              i' = show i
              st = part_group [type_A "start",number i'] as'
              en = part_group [type_A "stop",number i'] []
          in [st] ++ map x_score_part ps ++ [en]
      _ -> error "x_part_group: no ID or PART"

x_part_list :: [Part] -> X.Content
x_part_list =
    let fn x = case x of
                 (Part {}) -> [x_score_part x]
                 (Group {}) -> x_part_group x
    in part_list [] . concatMap fn

x_part :: Part -> X.Content
x_part p =
    case p of
      (Part (Just i) _ ms) ->
          let i' = 'P' : show i
              ms' = set_divisions ms
          in part [id_A i'] (zipWith (curry x_measure) [1..] ms')
      _ -> error "x_part: no ID or GROUP"

part_set_id :: (ID,Part) -> (ID,Part)
part_set_id (i,x) =
    case x of
      (Part Nothing pa vs) -> (i+1,Part (Just i) pa vs)
      (Group Nothing ga ps) ->
          let (i',ps') = mapAccumL (curry part_set_id) (i+1) ps
          in (i',Group (Just i) ga ps')
      _ -> error "part_set_id: has ID"

score_set_ids :: Score -> Score
score_set_ids (Score xs) =
    let (_,xs') = mapAccumL (curry part_set_id) 0 xs
    in Score xs'

x_score :: Score -> [X.Content]
x_score s =
    let (Score xs) = score_set_ids s
        pl = x_part_list xs
        f x = case x of
                (Part {}) -> [x]
                (Group _ _ ps) -> ps
        pt = map x_part (concatMap f xs)
    in pl : pt

-- | Make header from tuple of /title/, /number/, /dedication/ and
-- /composer/.
x_header :: (String,String,String,String) -> [X.Content]
x_header (t,n,d,c) =
    let t' = work_title [] [cdata t]
        n' = work_number [] [cdata n]
        c' = creator [type_A "composer"] [cdata c]
        d' = credit_words [] [cdata d]
    in [work [] [n',t']
       ,identification [] [c']
       ,credit [] [d']]

score_partwise' :: [X.Attr] -> [X.Content] -> X.Element
score_partwise' z e = X.Element (X.unqual "score-partwise") z e Nothing

renderMusicXML :: [X.Content] -> String
renderMusicXML xs =
    unlines [musicxml_xml
            ,musicxml_partwise
            ,X.ppElement (score_partwise' [] xs)]