-- | Rational quarter-note notation for durations.
module Music.Theory.Duration.Rq where

import Data.Function {- base -}
import Data.List {- base -}
import Data.Maybe {- base -}
import Data.Ratio {- base -}

import qualified Music.Theory.List as T {- hmt-base -}

import Music.Theory.Duration {- hmt -}

-- | Rational Quarter-Note
type Rq = Rational

{- | Table mapping tuple Rq values to Durations.
     Only has cases where the duration can be expressed without a tie.
     Currently has entries for 3-,5-,6- and 7-tuplets.

> all (\(i,j) -> i == duration_to_rq j) rq_tuplet_duration_table == True
-}
rq_tuplet_duration_table :: [(Rq, Duration)]
rq_tuplet_duration_table :: [(Rq, Duration)]
rq_tuplet_duration_table =
  [(Rq
1forall a. Fractional a => a -> a -> a
/Rq
3,Integer -> Dots -> Rq -> Duration
Duration Integer
8 Dots
0 (Rq
2forall a. Fractional a => a -> a -> a
/Rq
3))
  ,(Rq
2forall a. Fractional a => a -> a -> a
/Rq
3,Integer -> Dots -> Rq -> Duration
Duration Integer
4 Dots
0 (Rq
2forall a. Fractional a => a -> a -> a
/Rq
3))
  ,(Rq
1forall a. Fractional a => a -> a -> a
/Rq
5,Integer -> Dots -> Rq -> Duration
Duration Integer
16 Dots
0 (Rq
4forall a. Fractional a => a -> a -> a
/Rq
5))
  ,(Rq
2forall a. Fractional a => a -> a -> a
/Rq
5,Integer -> Dots -> Rq -> Duration
Duration Integer
8 Dots
0 (Rq
4forall a. Fractional a => a -> a -> a
/Rq
5))
  ,(Rq
3forall a. Fractional a => a -> a -> a
/Rq
5,Integer -> Dots -> Rq -> Duration
Duration Integer
8 Dots
1 (Rq
4forall a. Fractional a => a -> a -> a
/Rq
5))
  ,(Rq
4forall a. Fractional a => a -> a -> a
/Rq
5,Integer -> Dots -> Rq -> Duration
Duration Integer
4 Dots
0 (Rq
4forall a. Fractional a => a -> a -> a
/Rq
5))
  ,(Rq
1forall a. Fractional a => a -> a -> a
/Rq
6,Integer -> Dots -> Rq -> Duration
Duration Integer
16 Dots
0 (Rq
2forall a. Fractional a => a -> a -> a
/Rq
3))
  ,(Rq
1forall a. Fractional a => a -> a -> a
/Rq
7,Integer -> Dots -> Rq -> Duration
Duration Integer
16 Dots
0 (Rq
4forall a. Fractional a => a -> a -> a
/Rq
7))
  ,(Rq
2forall a. Fractional a => a -> a -> a
/Rq
7,Integer -> Dots -> Rq -> Duration
Duration Integer
8 Dots
0 (Rq
4forall a. Fractional a => a -> a -> a
/Rq
7))
  ,(Rq
3forall a. Fractional a => a -> a -> a
/Rq
7,Integer -> Dots -> Rq -> Duration
Duration Integer
8 Dots
1 (Rq
4forall a. Fractional a => a -> a -> a
/Rq
7))
  ,(Rq
4forall a. Fractional a => a -> a -> a
/Rq
7,Integer -> Dots -> Rq -> Duration
Duration Integer
4 Dots
0 (Rq
4forall a. Fractional a => a -> a -> a
/Rq
7))
  ,(Rq
6forall a. Fractional a => a -> a -> a
/Rq
7,Integer -> Dots -> Rq -> Duration
Duration Integer
4 Dots
1 (Rq
4forall a. Fractional a => a -> a -> a
/Rq
7))
  ]

{- | Lookup rq_tuplet_duration_tbl.

> rq_tuplet_to_duration (1/3) == Just (Duration 8 0 (2/3))
-}
rq_tuplet_to_duration :: Rq -> Maybe Duration
rq_tuplet_to_duration :: Rq -> Maybe Duration
rq_tuplet_to_duration Rq
x = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Rq
x [(Rq, Duration)]
rq_tuplet_duration_table

{- | Make table of (Rq,Duration) associations.
     Only lists durations with a multiplier of 1.

> map (length . rq_plain_duration_tbl) [1,2,3] == [20,30,40]
> map (multiplier . snd) (rq_plain_duration_tbl 1) == replicate 20 1
-}
rq_plain_duration_tbl :: Dots -> [(Rq,Duration)]
rq_plain_duration_tbl :: Dots -> [(Rq, Duration)]
rq_plain_duration_tbl Dots
k = forall a b. (a -> b) -> [a] -> [b]
map (\Duration
d -> (Duration -> Rq
duration_to_rq Duration
d,Duration
d)) (Dots -> [Duration]
duration_set Dots
k)

rq_plain_to_duration :: Dots -> Rq -> Maybe Duration
rq_plain_to_duration :: Dots -> Rq -> Maybe Duration
rq_plain_to_duration Dots
k Rq
x = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Rq
x (Dots -> [(Rq, Duration)]
rq_plain_duration_tbl Dots
k)

rq_plain_to_duration_err :: Dots -> Rq -> Duration
rq_plain_to_duration_err :: Dots -> Rq -> Duration
rq_plain_to_duration_err Dots
k Rq
x = forall k v. Eq k => k -> [(k, v)] -> v
T.lookup_err Rq
x (Dots -> [(Rq, Duration)]
rq_plain_duration_tbl Dots
k)

{- | Rational quarter note to duration value.
     Lookup composite plain (hence dots) and tuplet tables.
     It is a mistake to hope this could handle tuplets directly in a general sense.
     For instance, a @3:2@ dotted note is the same duration as a plain undotted note.
     However it does give durations for simple notations of simple tuplet values.

> rq_to_duration 2 (3/4) == Just (Duration 8 1 1) -- dotted_eighth_note
> rq_to_duration 2 (1/3) == Just (Duration 8 0 (2/3))
-}
rq_to_duration :: Dots -> Rq -> Maybe Duration
rq_to_duration :: Dots -> Rq -> Maybe Duration
rq_to_duration Dots
k Rq
x = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Rq
x ([(Rq, Duration)]
rq_tuplet_duration_table forall a. [a] -> [a] -> [a]
++ Dots -> [(Rq, Duration)]
rq_plain_duration_tbl Dots
k)

-- | Variant of 'rq_to_duration' with error message.
rq_to_duration_err :: Show a => a -> Dots -> Rq -> Duration
rq_to_duration_err :: forall a. Show a => a -> Dots -> Rq -> Duration
rq_to_duration_err a
msg Dots
k Rq
n =
    let err :: a
err = forall a. HasCallStack => [Char] -> a
error ([Char]
"rq_to_duration:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (a
msg,Rq
n))
    in forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
err (Dots -> Rq -> Maybe Duration
rq_to_duration Dots
k Rq
n)

-- | Is 'Rq' a /cmn/ duration (ie. rq_plain_to_duration)
--
-- > map (rq_is_cmn 2) [1/4,1/5,1/8,3/32] == [True,False,True,True]
rq_is_cmn :: Dots -> Rq -> Bool
rq_is_cmn :: Dots -> Rq -> Bool
rq_is_cmn Dots
k = forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dots -> Rq -> Maybe Duration
rq_plain_to_duration Dots
k

-- | Convert a whole note division integer to an 'Rq' value.
--
-- > map whole_note_division_to_rq [1,2,4,8] == [4,2,1,1/2]
whole_note_division_to_rq :: Division -> Rq
whole_note_division_to_rq :: Integer -> Rq
whole_note_division_to_rq Integer
x =
    let f :: Integer -> Rq
f = (forall a. Num a => a -> a -> a
* Rq
4) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Fractional a => a -> a
recip forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Integral a => a -> a -> Ratio a
% Integer
1)
    in case Integer
x of
         Integer
0 -> Rq
8
         -1 -> Rq
16
         Integer
_ -> Integer -> Rq
f Integer
x

-- | Apply dots to an 'Rq' duration.
--
-- > map (rq_apply_dots 1) [1,2] == [1 + 1/2,1 + 1/2 + 1/4]
rq_apply_dots :: Rq -> Dots -> Rq
rq_apply_dots :: Rq -> Dots -> Rq
rq_apply_dots Rq
n Dots
d =
    let m :: [Rq]
m = forall a. (a -> a) -> a -> [a]
iterate (forall a. Fractional a => a -> a -> a
/ Rq
2) Rq
n
    in forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall i a. Integral i => i -> [a] -> [a]
genericTake (Dots
d forall a. Num a => a -> a -> a
+ Dots
1) [Rq]
m)

-- | Convert 'Duration' to 'Rq' value, see 'rq_to_duration' for partial inverse.
--
-- > let d = [Duration 2 0 1,Duration 4 1 1,Duration 1 1 1]
-- > map duration_to_rq d == [2,3/2,6] -- half_note,dotted_quarter_note,dotted_whole_note
duration_to_rq :: Duration -> Rq
duration_to_rq :: Duration -> Rq
duration_to_rq (Duration Integer
n Dots
d Rq
m) =
    let x :: Rq
x = Integer -> Rq
whole_note_division_to_rq Integer
n
    in Rq -> Dots -> Rq
rq_apply_dots Rq
x Dots
d forall a. Num a => a -> a -> a
* Rq
m

-- | 'compare' function for 'Duration' via 'duration_to_rq'.
--
-- > half_note `duration_compare_rq` quarter_note == GT
duration_compare_rq :: Duration -> Duration -> Ordering
duration_compare_rq :: Duration -> Duration -> Ordering
duration_compare_rq = forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Duration -> Rq
duration_to_rq

-- | 'Rq' modulo.
--
-- > map (rq_mod (5/2)) [3/2,3/4,5/2] == [1,1/4,0]
rq_mod :: Rq -> Rq -> Rq
rq_mod :: Rq -> Rq -> Rq
rq_mod Rq
i Rq
j
    | Rq
i forall a. Eq a => a -> a -> Bool
== Rq
j = Rq
0
    | Rq
i forall a. Ord a => a -> a -> Bool
< Rq
0 = Rq -> Rq -> Rq
rq_mod (Rq
i forall a. Num a => a -> a -> a
+ Rq
j) Rq
j
    | Rq
i forall a. Ord a => a -> a -> Bool
> Rq
j = Rq -> Rq -> Rq
rq_mod (Rq
i forall a. Num a => a -> a -> a
- Rq
j) Rq
j
    | Bool
otherwise = Rq
i

-- | Is /p/ divisible by /q/, ie. is the 'denominator' of @p/q@ '==' @1@.
--
-- > map (rq_divisible_by (3%2)) [1%2,1%3] == [True,False]
rq_divisible_by :: Rq -> Rq -> Bool
rq_divisible_by :: Rq -> Rq -> Bool
rq_divisible_by Rq
i Rq
j = forall a. Ratio a -> a
denominator (Rq
i forall a. Fractional a => a -> a -> a
/ Rq
j) forall a. Eq a => a -> a -> Bool
== Integer
1

-- | Is 'Rq' a whole number (ie. is 'denominator' '==' @1@.
--
-- > map rq_is_integral [1,3/2,2] == [True,False,True]
rq_is_integral :: Rq -> Bool
rq_is_integral :: Rq -> Bool
rq_is_integral = (forall a. Eq a => a -> a -> Bool
== Integer
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ratio a -> a
denominator

-- | Return 'numerator' of 'Rq' if 'denominator' '==' @1@.
--
-- > map rq_integral [1,3/2,2] == [Just 1,Nothing,Just 2]
rq_integral :: Rq -> Maybe Integer
rq_integral :: Rq -> Maybe Integer
rq_integral Rq
n = if Rq -> Bool
rq_is_integral Rq
n then forall a. a -> Maybe a
Just (forall a. Ratio a -> a
numerator Rq
n) else forall a. Maybe a
Nothing

-- | Derive the tuplet structure of a set of 'Rq' values.
--
-- > rq_derive_tuplet_plain [1/2] == Nothing
-- > rq_derive_tuplet_plain [1/2,1/2] == Nothing
-- > rq_derive_tuplet_plain [1/4,1/4] == Nothing
-- > rq_derive_tuplet_plain [1/3,2/3] == Just (3,2)
-- > rq_derive_tuplet_plain [1/2,1/3,1/6] == Just (6,4)
-- > rq_derive_tuplet_plain [1/3,1/6] == Just (6,4)
-- > rq_derive_tuplet_plain [2/5,3/5] == Just (5,4)
-- > rq_derive_tuplet_plain [1/3,1/6,2/5,1/10] == Just (30,16)
--
-- > map rq_derive_tuplet_plain [[1/3,1/6],[2/5,1/10]] == [Just (6,4)
-- >                                                      ,Just (10,8)]
rq_derive_tuplet_plain :: [Rq] -> Maybe (Integer,Integer)
rq_derive_tuplet_plain :: [Rq] -> Maybe (Integer, Integer)
rq_derive_tuplet_plain [Rq]
x =
    let i :: Integer
i = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall a. Integral a => a -> a -> a
lcm Integer
1 (forall a b. (a -> b) -> [a] -> [b]
map forall a. Ratio a -> a
denominator [Rq]
x)
        j :: Integer
j = let z :: [Integer]
z = forall a. (a -> a) -> a -> [a]
iterate (forall a. Num a => a -> a -> a
* Integer
2) Integer
2
            in forall a. HasCallStack => Maybe a -> a
fromJust (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Ord a => a -> a -> Bool
>= Integer
i) [Integer]
z) forall a. Integral a => a -> a -> a
`div` Integer
2
    in if Integer
i forall a. Integral a => a -> a -> a
`rem` Integer
j forall a. Eq a => a -> a -> Bool
== Integer
0 then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (Integer
i,Integer
j)

-- | Derive the tuplet structure of a set of 'Rq' values.
--
-- > rq_derive_tuplet [1/4,1/8,1/8] == Nothing
-- > rq_derive_tuplet [1/3,2/3] == Just (3,2)
-- > rq_derive_tuplet [1/2,1/3,1/6] == Just (3,2)
-- > rq_derive_tuplet [2/5,3/5] == Just (5,4)
-- > rq_derive_tuplet [1/3,1/6,2/5,1/10] == Just (15,8)
rq_derive_tuplet :: [Rq] -> Maybe (Integer,Integer)
rq_derive_tuplet :: [Rq] -> Maybe (Integer, Integer)
rq_derive_tuplet =
    let f :: (b, b) -> (b, b)
f (b
i,b
j) = let k :: Ratio b
k = b
i forall a. Integral a => a -> a -> Ratio a
% b
j
                  in (forall a. Ratio a -> a
numerator Ratio b
k,forall a. Ratio a -> a
denominator Ratio b
k)
    in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {b}. Integral b => (b, b) -> (b, b)
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Rq] -> Maybe (Integer, Integer)
rq_derive_tuplet_plain

-- | 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.
--
-- > map (rq_un_tuplet (3,2)) [1,2/3,1/2,1/3] == [3/2,1,3/4,1/2]
rq_un_tuplet :: (Integer,Integer) -> Rq -> Rq
rq_un_tuplet :: (Integer, Integer) -> Rq -> Rq
rq_un_tuplet (Integer
i,Integer
j) Rq
x = Rq
x forall a. Num a => a -> a -> a
* (Integer
i forall a. Integral a => a -> a -> Ratio a
% Integer
j)

-- | If an 'Rq' duration is un-representable by a single /cmn/
-- duration, give tied notation.
--
-- > catMaybes (map rq_to_cmn [1..9]) == [(4,1),(4,3),(8,1)]
--
-- > map rq_to_cmn [5/4,5/8] == [Just (1,1/4),Just (1/2,1/8)]
rq_to_cmn :: Rq -> Maybe (Rq,Rq)
rq_to_cmn :: Rq -> Maybe (Rq, Rq)
rq_to_cmn Rq
x =
    let (Integer
i,Integer
j) = (forall a. Ratio a -> a
numerator Rq
x,forall a. Ratio a -> a
denominator Rq
x)
        k :: Maybe (Integer, Integer)
k = case Integer
i of
              Integer
5 -> forall a. a -> Maybe a
Just (Integer
4,Integer
1)
              Integer
7 -> forall a. a -> Maybe a
Just (Integer
4,Integer
3)
              Integer
9 -> forall a. a -> Maybe a
Just (Integer
8,Integer
1)
              Integer
_ -> forall a. Maybe a
Nothing
        f :: (Integer, Integer) -> (Rq, Rq)
f (Integer
n,Integer
m) = (Integer
nforall a. Integral a => a -> a -> Ratio a
%Integer
j,Integer
mforall a. Integral a => a -> a -> Ratio a
%Integer
j)
    in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer, Integer) -> (Rq, Rq)
f Maybe (Integer, Integer)
k

{- | Predicate to determine if a segment can be notated
     either without a tuplet or with a single tuplet.

> rq_can_notate 2 [1/2,1/4,1/4] == True
> rq_can_notate 2 [1/3,1/6] == True
> rq_can_notate 2 [2/5,1/10] == True
> rq_can_notate 2 [1/3,1/6,2/5,1/10] == False
> rq_can_notate 2 [4/7,1/7,6/7,3/7] == True
> rq_can_notate 2 [4/7,1/7,2/7] == True
-}
rq_can_notate :: Dots -> [Rq] -> Bool
rq_can_notate :: Dots -> [Rq] -> Bool
rq_can_notate Dots
k [Rq]
x =
    let x' :: [Rq]
x' = case [Rq] -> Maybe (Integer, Integer)
rq_derive_tuplet [Rq]
x of
               Maybe (Integer, Integer)
Nothing -> [Rq]
x
               Just (Integer, Integer)
t -> forall a b. (a -> b) -> [a] -> [b]
map ((Integer, Integer) -> Rq -> Rq
rq_un_tuplet (Integer, Integer)
t) [Rq]
x
    in forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Dots -> Rq -> Bool
rq_is_cmn Dots
k) [Rq]
x'

-- * Time

-- | Duration in seconds of Rq given qpm
--
--   qpm = pulses-per-minute, rq = rational-quarter-note
--
-- > map (\sd -> rq_to_seconds_qpm (90 * sd) 1) [1,2,4,8,16] == [2/3,1/3,1/6,1/12,1/24]
-- > map (rq_to_seconds_qpm 90) [1,2,3,4] == [2/3,1 + 1/3,2,2 + 2/3]
-- > map (rq_to_seconds_qpm 90) [0::Rq,1,1 + 1/2,1 + 3/4,1 + 7/8,2] == [0,2/3,1,7/6,5/4,4/3]
rq_to_seconds_qpm :: Fractional a => a -> a -> a
rq_to_seconds_qpm :: forall a. Fractional a => a -> a -> a
rq_to_seconds_qpm a
qpm a
rq = a
rq forall a. Num a => a -> a -> a
* (a
60 forall a. Fractional a => a -> a -> a
/ a
qpm)

-- | Qpm given that /rq/ has duration /x/, ie. inverse of 'rq_to_seconds_qpm'
--
-- > map (rq_to_qpm 1) [0.4,0.5,0.8,1,1.5,2] == [150,120,75,60,40,30]
-- > map (\qpm -> rq_to_seconds_qpm qpm 1) [150,120,75,60,40,30] == [0.4,0.5,0.8,1,1.5,2]
rq_to_qpm :: Fractional a => a -> a -> a
rq_to_qpm :: forall a. Fractional a => a -> a -> a
rq_to_qpm a
rq a
x = (a
rq forall a. Fractional a => a -> a -> a
/ a
x) forall a. Num a => a -> a -> a
* a
60