module Music.Theory.Duration.Sequence.Notate
    (Duration_A
    ,notate
    ,ascribe
    ,group_boundary) where

import Data.List
import Data.Ratio
import Music.Theory.Duration

{-
import Debug.Trace
debug :: (Show a) => a -> x -> x
debug = traceShow
-}

debug :: (Show a) => a -> x -> x
debug _ x = x

type R = Rational
type D = (R,R,Bool,Bool) {- start_time duration tied_left tied_right -}
type Duration_A = (Duration,[D_Annotation])

d_duration :: D -> R
d_duration (_,x,_,_) = x

da_tied_right :: Duration_A -> Bool
da_tied_right = elem Tie_Right . snd

-- | dx -> d
integrate :: (Num a) => [a] -> [a]
integrate [] = []
integrate (x:xs) =
    let fn i c = (i + c, i + c)
    in x : snd (mapAccumL fn x xs)

-- xs = boundaries
-- d = duration
step_dur :: (Ord a, Num a) => [a] -> a -> ([a], [a])
step_dur [] _ = error "step_dur: no boundaries"
step_dur _ 0 = error "step_dur: zero duration"
step_dur (x:xs) d =
    let jn a (a',b) = (a:a',b)
    in case compare d x of
         EQ -> ([d],xs)
         LT -> ([d],(x-d):xs)
         GT -> jn x (step_dur xs (d - x))

{-
step_dur [2,1,3] 5
step_dur [3%2,3%2,3%2] 2
-}

-- xs = boundaries
-- d(s) = duration(s)
boundaries :: (Num a, Ord a) => [a] -> [a] -> [[a]]
boundaries =
    let go [] _ = []
        go _ [] = []
        go xs (d:ds) =
            let (d',xs') = step_dur xs d
            in d' : go xs' ds
    in go

{-
boundaries (repeat 3) [1..5]
boundaries (repeat (3%2)) [1%2,1..5]
-}

-- i = initial start time
-- xs = durations
with_start_times :: (Num a) => a -> [a] -> [(a,a)]
with_start_times i xs =
    let is = map (+i) (0 : integrate xs)
    in zip is xs

-- variant starting at zero and processing sets of durations
with_start_times' :: (Num a) => [[a]] -> [[(a, a)]]
with_start_times' xs =
    let is = 0 : integrate (map sum xs)
    in zipWith with_start_times is xs

{-
with_start_times 0 [4,3,5,2,1]
with_start_times' [[4,3,5],[2,1],[6,3]]
with_start_times' (boundaries [3,3,3,3,3] [4,3,5,2,1])
let xs = [3%4,2%1,5%4,9%4,1%4,3%2,1%2,7%4,1%1,5%2,11%4,3%2]
with_start_times 0 xs
with_start_times' (boundaries (repeat (3%2)) xs)
-}

-- split list into first element, possibly empty 'middle' elements,
-- and end element
start_middle_end :: [x] -> (x,[x],x)
start_middle_end xs =
    case xs of
      (_:_:_) -> let n = length xs
                     x0 = xs !! 0
                     xn = xs !! (n - 1)
                 in (x0,take (n - 2) (drop 1 xs),xn)
      _ -> error "start_middle_end: list must have at least two elements"

{-
start_middle_end []
start_middle_end [1..6]
-}

-- xs = [(start-time,duration)]
tied_r_to_d :: [(R,R)] -> [D]
tied_r_to_d xs =
    case xs of
      [] -> []
      [(s,d)] -> [(s,d,False,False)]
      _ -> let ((s0,d0),xs',(sn,dn)) = start_middle_end xs
               f (s,d) = (s,d,True,True)
            in (s0,d0,False,True) : map f xs' ++ [(sn,dn,True,False)]

boundaries_d :: [R] -> [R] -> [D]
boundaries_d xs ds =
    let bs = boundaries xs ds
    in concatMap tied_r_to_d (with_start_times' bs)

{-
boundaries_d [3,3,3,3,3,3,3,3] [4,3,5,2,1,7,2]
-}

-- | rational modulo
r_mod :: R -> R -> R
r_mod i j
    | i == j = 0
    | i < 0 = r_mod (i + j) j
    | i > j = r_mod (i - j) j
    | otherwise = i

{-
-- n = boundary
-- i = phase
sep_at :: R -> R -> R -> [D]
sep_at =
    let go l n i x =
            let i' = n - (i `r_mod` n)
            in if x > i'
               then let d = (i,i',l,True)
                    in d : go True n (i + i') (x - i')
               else [(i,x,l,False)]
    in go False

{-
sep_at 1 (1%2) 1
sep_at 1 (1%3) (6%3)
-}
-}

-- unrep = un-representable by single cmn duration (ie. requires tie)
-- i = phase
-- x = duration
sep_unrep :: R -> R -> Maybe (R,R)
sep_unrep i x =
    let i' = denominator i == 1
        j = case numerator x of
              5 -> Just (1,4)
              7 -> Just (3,4)
              _ -> Nothing
        f (n,m) = (n % denominator x,m % denominator x)
        swap (a,b) = (b,a)
    in case j of
         Nothing -> Nothing
         Just j' -> Just (f (if i' then swap j' else j'))

sep_unrep_d :: D -> [D]
sep_unrep_d d =
    let (i,x,l,r) = d
    in case sep_unrep i x of
         Nothing -> [d]
         Just (x0,x1) -> [(i,x0,l,True),(i+x0,x1,True,r)]

{-
zipWith sep_unrep [1,3%8,1] [5%4,5%8,4]
zipWith (\i x -> sep_unrep_d (i,x,False,False)) [1,3%8,1] [5%4,5%8,4]
-}

separate :: [R] -> [R] -> [D]
separate ns = concatMap sep_unrep_d . boundaries_d ns

{-
let xs = [3%4,2%1,5%4,9%4,1%4,3%2,1%2,7%4,1%1,5%2,11%4,3%2]
separate (repeat (1%2)) xs
-}

-- | group to n, or to multiple of
group_boundary :: (a -> R) -> [R] -> [a] -> [[a]]
group_boundary dur_f =
    let go _ [] [] _ = []
        go _ _ [] _ = error "group_boundary: no boundaries?"
        go _ js _ [] = [reverse js]
        go _ js _ [x] = [reverse (x:js)]
        go c js (n:ns) (x:xs) =
            let c' = c + dur_f x
            in case compare c' n of
                 EQ -> reverse (x:js) : go 0 [] ns xs
                 LT -> go c' (x:js) (n:ns) xs
                 GT -> let c'' = c' - n
                       in if c'' `divisible_by` n
                          then reverse (x:js) : go 0 [] ns xs
                          else go c'' (x:js) ns xs
    in go 0 []

{-
group_boundary id [1,1,1] [2,1%2,1%2]
-}

group_boundary_d :: [R] -> [D] -> [[D]]
group_boundary_d = group_boundary d_duration

{-
group_boundary id [3,3,3] (cycle [1,2,3])

let i = [1,1%2,2,1%3,5%3,1%8,1%2,7%8]
in group_boundary_d (repeat 1) (separate (repeat 1) i)
-}

derive_tuplet :: [D] -> Maybe (Integer,Integer)
derive_tuplet xs =
    let xs' = map d_duration xs
        i = maximum (map denominator xs')
        smpl n = if even n then smpl (n `div` 2) else n
        i' = smpl i
        j = case i' of
              3 -> (3,2)
              5 -> (5,4)
              7 -> (7,4)
              9 -> (9,8)
              _ -> error ("derive_tuplet: " ++ show (i,i'))
    in if i' == 1
       then Nothing
       else Just j

{-
let i = [1,1%2,2,1%3,5%3,1%8,1%2,7%8]
in map derive_tuplet (group_boundary_d 1 (separate 1 i))
-}

-- remove tuplet multiplier from value (ie. to give notated duration)
-- this seems odd but is neccessary to avoid ambiguity (ie. is 1 a
-- quarter note or a 3:2 tuplet dotted-quarter-note etc.
un_tuplet :: (Integer,Integer) -> R -> R
un_tuplet (i,j) x = x * (i%j)

d_join_aligned :: D -> D -> Maybe D
d_join_aligned (s1,x1,l1,r1) (_,x2,_,r2)
    | (x1 == (1%4) && r1 && x2 `elem` [1%4,1%2,3%4]) ||
      (x1 == (1%2) && r1 && x2 `elem` [1%4,1%2,1,3%2]) ||
      (x1 == 1 && r1 && x2 `elem` [1%2,1,2]) ||
      (x1 == (3%2) && r1 && x2 `elem` [1%2,3%2]) ||
      (x1 == 2 && r1 && x2 `elem` [1,2]) = debug ("aligned-join",s1,x1,x2) (Just (s1,x1+x2,l1,r2))
    | otherwise = debug ("aligned-no-join",s1,x1,r1,x2) Nothing

divisible_by :: R -> R -> Bool
divisible_by i j = denominator (i / j) == 1

-- partial/incomplete/inaccurate
d_join :: R -> D -> D -> Maybe D
d_join a (s1,x1,l1,r1) (s2,x2,l2,r2)
    | s1 `divisible_by` a = d_join_aligned (s1,x1,l1,r1) (s2,x2,l2,r2)
    | denominator (s1 `r_mod` 1) == 4 &&
      x1 == 1%4 &&
      r1 &&
      x2 == 1%4 &&
      not (s2 `divisible_by` a) =
      debug ("non-aligned-join",a,s1,x1) (Just (s1,x1+x2,l1,r2))
    | s1 `r_mod` 1 == 2%3 &&
      x1 == 1%3 &&
      r1 &&
      x2 == 1%3 =
      debug ("non-aligned-join",a,s1,x1) (Just (s1,x1+x2,l1,r2))
    | otherwise = debug ("non-aligned-no-join",a,s1,x1) Nothing

{-
d_join 1 (7 % 4,1 % 4,False,True) (2 % 1,1 % 4,True,False)
-}

{-
-- error checking variant
d_join' :: R -> D -> D -> Maybe D
d_join' a d1 d2 =
    case d_join a d1 d2 of
      Nothing -> Nothing
      Just x -> let (_,y,_,_) = x
                in case rq_to_duration y of
                     Nothing -> error ("d_join' :" ++ show (a,d1,d2,x))
                     Just _ -> Just x
-}

coalesce :: (a -> a -> Maybe a) -> [a] -> [a]
coalesce f xs =
    case xs of
      (x1:x2:xs') -> case f x1 x2 of
                       Nothing -> x1 : coalesce f (x2:xs')
                       Just x' -> coalesce f (x':xs')
      _ -> xs

-- a = alignment
-- ns = boundaries
-- two pass, ie. [2,1%2,1%2] becomes [2,1] becomes [3]
simplify :: R -> [R] -> [D] -> [D]
simplify a ns xs =
    let xs' = group_boundary_d ns xs
        pass :: [[D]] -> [[D]]
        pass = map (coalesce (d_join a))
    in concat ((pass . pass) xs')

-- erroring variant of rq_to_duration
to_duration :: Show a => a -> R -> Duration
to_duration msg n =
    let err = error ("to_duration:" ++ show (msg,n))
    in maybe err id (rq_to_duration n)

tuplet :: (Integer,Integer) -> [Duration] -> [Duration_A]
tuplet (d,n) xs =
    let fn x = x { multiplier = n%d }
        xn = length xs
        (Just ty) = rq_to_duration (sum (map duration_to_rq xs) / (d%1))
        t0 = [Begin_Tuplet (d,n,ty)]
        ts = [t0] ++ replicate (xn - 2) [] ++ [[End_Tuplet]]
    in zip (map fn xs) ts

-- the d0:dN distinction is to catch, for instance, dotted 1/4 and
-- tuplet 1/16.  it'd be better to not simplify to that, however
-- simplifier does not look ahead.
notate_sec :: [D] -> [Duration_A]
notate_sec xs =
    let ds = map d_duration xs
        add_ties_from (_,_,l,r) (d,fs) =
            let l' = if l then [Tie_Left] else []
                r' = if r then [Tie_Right] else []
            in (d,l' ++ r' ++ fs)
        xs' = case derive_tuplet xs of
                Nothing -> let f = to_duration ("no-tuplet",ds)
                           in map (\d -> (f d,[])) ds
                Just t -> let f = to_duration ("tuplet",t,ds)
                              (d0:dN) = ds
                          in if denominator d0 == 2
                             then (f d0,[]) : tuplet t (map (f . un_tuplet t) dN)
                             else tuplet t (map (f . un_tuplet t) ds)
    in zipWith add_ties_from xs xs'

-- is = unit divisions (must not conflict with ns)
-- ns = boundaries (ie. measures)
-- xs = durations
-- note: alignments are not handled correctly
notate :: [R] -> [R] -> [R] -> [Duration_A]
notate is ns xs =
    let xs' = simplify (head is) ns (separate is xs)
    in concatMap notate_sec (group_boundary_d is xs')

{-
let xs = [2%3,2%3,2%3,3%2,3%2,2%3,2%3,2%3,1%2,1%2,5%2,3%2]
let xs = map (%4) [1,6,2,3]
let xs = [2 % 1, 3 % 5, 2 % 5]
let is = repeat (1%1)
let ns = repeat (3%1)

map (\(x,y) -> (duration_to_lilypond_type x,y)) (notate is ns xs)
separate is xs
let xs' = simplify (head is) ns (separate is xs)
group_boundary_d is xs'
-}

ascribe_fn :: (x -> Bool) -> [x] -> [a] -> [(x,a)]
ascribe_fn fn =
    let go [] _ = []
        go _ [] = error "ascribe_fn"
        go (x:xs) (i:is) = let is' = if fn x then (i:is) else is
                           in (x,i) : go xs is'
    in go

ascribe :: [Duration_A] -> [x] -> [(Duration_A,x)]
ascribe = ascribe_fn da_tied_right