module Music.Typesetting.Literal where

import Data.List
import Data.Maybe
import Data.Ratio
import Music.Theory.Duration
import Music.Typesetting.Model
import Music.Typesetting.Query

-- * Functions for writing music by hand.

n_annotate :: N_Annotation -> Note -> Note
n_annotate a (Note d as) = Note d (a : as)

(&) :: Note -> N_Annotation -> Note
(&) = flip n_annotate

annotate_first :: (a -> x -> x) -> a -> [x] -> [x]
annotate_first fn a ns =
    case ns of
      [] -> []
      (n:ns') -> fn a n : ns'

annotate_last :: (a -> x -> x) -> a -> [x] -> [x]
annotate_last fn a ns =
    case ns of
      [] -> []
      [n] -> [fn a n]
      (n:ns') -> n : annotate_last fn a ns'

annotate_bracket :: (a -> x -> x) -> (a,a) -> [x] -> [x]
annotate_bracket fn (a0,an) = annotate_last fn an . annotate_first fn a0

n_annotate_l :: [N_Annotation] -> Note -> Note
n_annotate_l as' (Note d as) = Note d (as ++ as')

n_annotate_first :: [N_Annotation] -> [Note] -> [Note]
n_annotate_first = annotate_first n_annotate_l

n_annotate_last :: [N_Annotation] -> [Note] -> [Note]
n_annotate_last = annotate_last n_annotate_l

n_annotate_bracket :: (N_Annotation,N_Annotation) -> [Note] -> [Note]
n_annotate_bracket = annotate_bracket n_annotate

-- | Apply annotations to the start and end points of each tied note.
n_annotate_tie_endpoints :: (N_Annotation,N_Annotation) -> Note -> Note
n_annotate_tie_endpoints (a0,an) n
    | n_is_initial_tie n = n & a0
    | n_is_final_tie n = n &an
    | otherwise = n

n_edit_duration :: (Duration -> Duration) -> Note -> Note
n_edit_duration fn (Note d xs) = Note (fn d) xs

-- note: ought to set Tuplet_T
tuplet :: (Integer,Integer) -> [Note] -> [Note]
tuplet (d,n) =
    let fn x = x { multiplier = n%d }
        ann = n_annotate_bracket (N_Begin_Tuplet Nothing,N_End_Tuplet)
    in map (n_edit_duration fn) . ann

m_annotate :: M_Annotation -> Measure -> Measure
m_annotate a (Measure as ns) = Measure (a : as) ns

(&.) :: Measure -> M_Annotation -> Measure
(&.) = flip m_annotate

m_annotate_l :: [M_Annotation] -> Measure -> Measure
m_annotate_l as' (Measure as ns) = Measure (as ++ as') ns

m_annotate_first :: [M_Annotation] -> [Measure] -> [Measure]
m_annotate_first = annotate_first m_annotate_l

m_annotate_last :: [M_Annotation] -> [Measure] -> [Measure]
m_annotate_last = annotate_last m_annotate_l

m_annotate_bracket :: (M_Annotation,M_Annotation) -> [Measure] -> [Measure]
m_annotate_bracket = annotate_bracket m_annotate

m_duration :: Measure -> [Duration]
m_duration (Measure _ ns) = mapMaybe n_duration_forward ns

m_duration_rq :: Measure -> Rational
m_duration_rq = sum . map duration_to_rq . m_duration

empty_measure :: (Integer,Integer) -> Measure
empty_measure n = Measure [M_Time_Signature n] []

stem_tremolo :: Integer -> Note -> Note
stem_tremolo n (Note d a) =
    let x = duration_beam_count d
        x' = max 0 (n - x)
    in Note d (N_Stem_Tremolo x' : a)

pppp,ppp,pp,p,mp,mf,f,ff,fff,ffff,fp,sfz :: N_Annotation
pppp = N_Dynamic_Mark PPPP
ppp = N_Dynamic_Mark PPP
pp = N_Dynamic_Mark PP
p = N_Dynamic_Mark P
mp = N_Dynamic_Mark MP
mf = N_Dynamic_Mark MF
f = N_Dynamic_Mark F
ff = N_Dynamic_Mark FF
fff = N_Dynamic_Mark FFF
ffff = N_Dynamic_Mark FFFF
fp = N_Dynamic_Mark FP
sfz = N_Dynamic_Mark SFZ

cresc,dim :: N_Annotation
cresc = N_Crescendo
dim = N_Diminuendo

bass_clef,tenor_clef,alto_clef,treble_clef,percussion_clef :: M_Annotation
bass_clef = M_Clef Bass 0
tenor_clef = M_Clef Tenor 0
alto_clef = M_Clef Alto 0
treble_clef = M_Clef Treble 0
percussion_clef = M_Clef Percussion 0

bass_8vb_clef,treble_8va_clef,treble_8vb_clef,treble_15ma_clef :: M_Annotation
bass_8vb_clef = M_Clef Bass (-1)
treble_8va_clef = M_Clef Treble 1
treble_8vb_clef = M_Clef Treble (-1)
treble_15ma_clef = M_Clef Treble 2

accent :: N_Annotation
accent = N_Articulation Accent

-- * Parts, groups etc.

part :: Name -> [Measure] -> Part
part nm ms = Part Nothing [P_Name nm] ms

group :: Name -> [Part] -> Part
group nm ps = Group Nothing [G_Name nm] ps

-- merge parallel voices
voices :: [[Measure]] -> [Measure]
voices vs =
    let vs' = transpose vs
        vc_ann :: Integer -> Measure -> Measure
        vc_ann i (Measure as ns) = Measure as (map (& (N_Voice i)) ns)
        merge_m_ann :: [Measure] -> [M_Annotation]
        merge_m_ann = foldl1 union . map m_annotations
        fn ms = let (d:_) = map m_duration ms
                    bu = N_Backup d
                    ms' = zipWith vc_ann [1..] ms
                    ns = concatMap (n_annotate_last [bu] . m_notes) ms'
                    as = merge_m_ann ms
                in Measure as ns
    in map fn vs'

-- * Interop

-- note: ought to translate begin_tuplet correctly
from_d_annotation :: D_Annotation -> N_Annotation
from_d_annotation x =
    case x of
      Tie_Right -> N_Begin_Tied
      Tie_Left -> N_End_Tied
      Begin_Tuplet (n,d,i) -> N_Begin_Tuplet (Just (n,i,d,i))
      End_Tuplet -> N_End_Tuplet