module Music.Typesetting.Query where

import Data.Function
import Data.List
import Data.Maybe
import Music.Theory.Dynamic_Mark {- hmt -}
import Music.Theory.Duration
import Music.Theory.Duration.Name
import Music.Theory.Duration.RQ
import Music.Theory.Pitch
import Music.Theory.Tempo_Marking
import Music.Theory.Time_Signature
import Music.Typesetting.Model

-- * Note annotation

na_pitch :: N_Annotation -> Maybe Pitch
na_pitch a =
    case a of
      N_Pitch x -> Just x
      _ -> Nothing

na_dynamic_mark :: N_Annotation -> Maybe Dynamic_Mark_T
na_dynamic_mark a =
    case a of
      N_Direction (D_Dynamic_Mark x) -> Just x
      _ -> Nothing

na_is_dynamic_mark :: N_Annotation -> Bool
na_is_dynamic_mark = isJust . na_dynamic_mark

na_is_dynamic_annotation :: N_Annotation -> Bool
na_is_dynamic_annotation a =
    case a of
      N_Direction (D_Dynamic_Mark _) -> True
      N_Direction (D_Hairpin _) -> True
      _ -> False

na_is_begin_hairpin :: N_Annotation -> Bool
na_is_begin_hairpin a =
    case a of
      N_Direction (D_Hairpin Crescendo) -> True
      N_Direction (D_Hairpin Diminuendo) -> True
      _ -> False

na_is_begin_dynamic :: N_Annotation -> Bool
na_is_begin_dynamic a = na_is_dynamic_mark a || na_is_begin_hairpin a

na_annotated_tied_lr :: [N_Annotation] -> (Bool,Bool)
na_annotated_tied_lr a = (N_End_Tied `elem` a,N_Begin_Tied `elem` a)

data At_Tied = At_End_Tied | At_Either_Tied | At_Begin_Tied
               deriving (Eq,Enum,Ord,Show)

na_annotation_at_tied :: N_Annotation -> At_Tied
na_annotation_at_tied a =
    let err = error (show ("na_annotation_at_tied",a))
    in case a of
      N_Grace -> At_Begin_Tied
      N_Chord -> At_Either_Tied
      N_Pitch _ -> At_Either_Tied
      N_Unpitched -> At_Either_Tied
      N_Rest -> At_Either_Tied
      N_Notehead _ -> At_Either_Tied
      N_Staff _ -> At_Either_Tied
      N_Beam _ _ -> At_Either_Tied
      N_Begin_Tied -> err
      N_End_Tied -> err
      N_Begin_Slur -> At_Begin_Tied
      N_End_Slur -> At_End_Tied
      N_Begin_Tuplet _ -> err
      N_End_Tuplet -> err
      N_Begin_Glissando -> At_End_Tied
      N_End_Glissando -> At_Begin_Tied
      N_Begin_Slide -> At_End_Tied
      N_End_Slide -> At_Begin_Tied
      N_Stem_Tremolo _ -> At_Either_Tied
      N_Ornament Trill_Mark -> At_Begin_Tied
      N_Technical _ -> At_Begin_Tied
      N_Articulation _ -> At_Begin_Tied
      N_Fermata -> At_End_Tied
      N_Arpeggiate -> At_Begin_Tied
      N_Direction (D_Dynamic_Mark _) -> At_Begin_Tied
      N_Direction (D_Hairpin Crescendo) -> At_Begin_Tied
      N_Direction (D_Hairpin Diminuendo) -> At_Begin_Tied
      N_Direction (D_Hairpin End_Hairpin) -> At_End_Tied
      N_Direction D_Laissez_Vibrer -> At_End_Tied
      N_Direction (D_Tempo_Marking _) -> At_Begin_Tied
      N_Direction (D_Pedal {}) -> At_Begin_Tied
      N_Voice _ -> At_Either_Tied
      N_Backup _ -> err

na_annotation_at_end_tied_only :: N_Annotation -> Bool
na_annotation_at_end_tied_only = (== At_End_Tied) . na_annotation_at_tied

na_annotation_at_tied_either :: N_Annotation -> Bool
na_annotation_at_tied_either = (== At_Either_Tied) . na_annotation_at_tied

-- * Note

n_has_annotation :: N_Annotation -> Note -> Bool
n_has_annotation x (Note _ xs) = x `elem` xs

n_is_rest :: Note -> Bool
n_is_rest = n_has_annotation N_Rest

n_is_chord_elem :: Note -> Bool
n_is_chord_elem = n_has_annotation N_Chord

n_is_untied :: Note -> Bool
n_is_untied n = not (n_has_annotation N_Begin_Tied n ||
                     n_has_annotation N_End_Tied n)

n_is_initial_tie :: Note -> Bool
n_is_initial_tie n = n_has_annotation N_Begin_Tied n &&
                     not (n_has_annotation N_End_Tied n)

n_is_final_tie :: Note -> Bool
n_is_final_tie n = n_has_annotation N_End_Tied n &&
                   not (n_has_annotation N_Begin_Tied n)

n_pitch :: Note -> Maybe Pitch
n_pitch (Note _ as) =
    case mapMaybe na_pitch as of
      [] -> Nothing
      [x] -> Just x
      _ -> error "n_pitch"

n_has_pitch :: Note -> Bool
n_has_pitch = isJust . n_pitch

n_dynamic_mark :: Note -> Maybe Dynamic_Mark_T
n_dynamic_mark (Note _ as) =
    case mapMaybe na_dynamic_mark as of
      [] -> Nothing
      [x] -> Just x
      _ -> error "n_dynamic_mark: multiple marks"

n_has_dynamic_mark :: Note -> Bool
n_has_dynamic_mark = isJust . n_dynamic_mark

n_duration_forward :: Note -> Maybe Duration
n_duration_forward n =
    let (Note d _) = n
    in if n_is_chord_elem n
       then Nothing
       else Just d

-- * Measure annotation

ma_time_signature_t :: M_Annotation -> Maybe Time_Signature
ma_time_signature_t m =
    case m of
      M_Time_Signature x -> Just x
      _ -> Nothing

ma_tempo_marking_t:: M_Annotation -> Maybe Tempo_Marking
ma_tempo_marking_t a =
    case a of
      M_Direction (D_Tempo_Marking x) -> Just x
      _ -> Nothing

-- * Measure

-- | 'Just' /a/ for singleton list, else 'Nothing'.
list_to_maybe :: [a] -> Maybe a
list_to_maybe l =
    case l of
      [e] -> Just e
      _ -> Nothing

m_time_signature :: Measure -> [M_Annotation]
m_time_signature = filter (isJust . ma_time_signature_t) . m_annotations

m_time_signature' :: Measure -> Maybe M_Annotation
m_time_signature' = list_to_maybe . m_time_signature

m_time_signature_t :: Measure -> [Time_Signature]
m_time_signature_t = mapMaybe ma_time_signature_t . m_annotations

m_tempo_marking :: Measure -> [M_Annotation]
m_tempo_marking = filter (isJust . ma_tempo_marking_t) . m_annotations

m_tempo_marking' :: Measure -> Maybe M_Annotation
m_tempo_marking' = list_to_maybe . m_tempo_marking

m_tempo_marking_t :: Measure -> [Tempo_Marking]
m_tempo_marking_t = mapMaybe ma_tempo_marking_t . m_annotations

-- * Temporal map

type SI_Map a = [(Integer,a)]
type Time_Signature_Map = SI_Map Time_Signature
type Tempo_Marking_Map = SI_Map Tempo_Marking
type Temporal_Map = (Integer,Time_Signature_Map,Tempo_Marking_Map)

si_map_to_sequence :: Integer -> a -> SI_Map a -> [a]
si_map_to_sequence n df mp =
    let mp' = (0,df) : mp ++ [(n,undefined)]
        fn (i,x) (j,_) = genericReplicate (j - i) x
    in concat (zipWith fn mp' (tail mp'))

mm_time_signature_map :: [Measure] -> Time_Signature_Map
mm_time_signature_map =
    let fn (i,m) = case m_time_signature_t m of
                     [] -> Nothing
                     [x] -> Just (i,x)
                     _ -> error "mm_time_signature_map"
    in mapMaybe fn . zip [0..]

mm_tempo_marking_map :: [Measure] -> Tempo_Marking_Map
mm_tempo_marking_map =
    let fn (i,m) = case m_tempo_marking_t m of
                     [] -> Nothing
                     [x] -> Just (i,x)
                     _ -> error "mm_tempo_marking_map"
    in mapMaybe fn . zip [0..]

mm_temporal_map :: [Measure] -> Temporal_Map
mm_temporal_map xs =
    let ts_m = mm_time_signature_map xs
        tm_m = mm_tempo_marking_map xs
    in (genericLength xs,ts_m,tm_m)

-- | dx -> d
--
-- > integrate [1,3,6,10] == [1,4,10,20]
integrate :: (Num a) => [a] -> [a]
integrate = scanl1 (+)

temporal_map_locate :: Temporal_Map -> [(Rational,Rational,Tempo_Marking)]
temporal_map_locate (n,ts_m,tm_m) =
    let ts_s = si_map_to_sequence n (4,4) ts_m
        tm_s = si_map_to_sequence n (quarter_note,60) tm_m
        dd = zipWith measure_duration ts_s tm_s
        st = 0 : integrate dd
    in zip3 st dd tm_s

n_locate :: (Rational,Rational,Tempo_Marking) -> [Note] -> [(Rational,Note)]
n_locate (st,_,tm) =
    let fn i n = let j = maybe 0 duration_to_rq (n_duration_forward n)
                     j' = rq_to_seconds tm j
                 in (i + j', (i,n))
    in snd . mapAccumL fn st

locate_notes :: [[Measure]] -> [(Rational,Note)]
locate_notes mms =
    let tm = mm_temporal_map (head mms)
        lm = temporal_map_locate tm
        mk_ns ms = concat (zipWith n_locate lm (map m_notes ms))
    in sortBy (compare `on` fst) (concatMap mk_ns mms)