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.Duration as T
import qualified Music.Theory.Key as T
import qualified Music.Theory.Pitch as T
import qualified Text.XML.Light as X

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

x_clef :: (Clef_T,Integer) -> X.Content
x_clef (c,i) =
    let (s,l) = x_clef_t c
        a = [{-number "1"-}]
    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' = maybe T.Natural id a
    in key [] [fifths [] [cdata (show (T.key_fifths (n,a',m)))]
              ,mode [] [cdata (key_mode_t m)]]

x_time :: (Integer,Integer) -> 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))]
             ,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 :: N_Annotation -> Maybe X.Content
x_ornament x =
    case x of
      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_technical_el :: N_Annotation -> Maybe X.Content
x_technical_el x =
    case x of
      N_Natural_Harmonic -> Just (harmonic [] [natural []])
      _ -> 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

-- note: this requires '_' -> '-' translation
x_articulation_t :: Articulation_T -> X.Content
x_articulation_t = mk_empty_elem_no_attr . map toLower . 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 :: 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_Slur -> Just (slur [type_A "start"])
      N_End_Slur -> Just (slur [type_A "stop"])
      N_Begin_Tied -> Just (tied [type_A "start"])
      N_End_Tied -> Just (tied [type_A "stop"])
      N_Begin_Tuplet t -> Just (tuplet [type_A "start"] (x_tuplet_t t))
      N_End_Tuplet -> Just (tuplet [type_A "stop"] [])
      _ -> 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 :: Tempo_Marking_T -> 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_n_direction :: N_Annotation -> Maybe X.Content
x_n_direction x =
    case x of
      N_Crescendo ->
          let ty = direction_type [] [wedge [type_A "crescendo"]]
          in Just (direction [x_placement_t Below] [ty])
      N_Diminuendo ->
          let ty = direction_type [] [wedge [type_A "diminuendo"]]
          in Just (direction [x_placement_t Below] [ty])
      N_End_Hairpin ->
          let ty = direction_type [] [wedge [type_A "stop"]]
          in Just (direction [x_placement_t Below] [ty])
      _ -> Nothing

x_m_direction :: M_Annotation -> Maybe X.Content
x_m_direction x =
    case x of
      M_Tempo_Marking m -> Just (x_metronome m)
      _ -> 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_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
        ac = x_accidental xs
        vc = x_voice xs
        m' = maybe [] return m
        n = note [] (es ++ [d'] ++ vc ++ ty_dt ++ ac ++ m' ++ nt)
    in dr ++ [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 i -> Just (x_clef (c,i))
      M_Key n a m -> Just (x_key (n,a,m))
      M_Time_Signature i -> Just (x_time i)
      M_Tempo_Marking _ -> 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 "set_divisions"
      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'] (map x_measure (zip [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

-- t = title, n = number, d = dedication, c = 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 =
    concat [musicxml_xml
           ,musicxml_partwise
           ,X.showElement (score_partwise' [] xs)]