{-# LANGUAGE CPP #-}
module Perform.Lilypond.Meter (
Meter, meter_nums, meter_denom
, time_num
, default_meter
, measure_time
, unparse_meter, parse_meter
, is_binary
, allowed_duration
#ifdef TESTING
, module Perform.Lilypond.Meter
#endif
) where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Vector.Unboxed as Vector
import Data.Vector.Unboxed ((!))
import qualified Util.Num as Num
import qualified Util.P as P
import qualified Util.Parse as Parse
import qualified Util.Lists as Lists
import qualified Perform.Lilypond.Types as Types
import Perform.Lilypond.Types (Duration(..), NoteDuration(..), Time)
import qualified Ui.Meter.Make as Meter.Make
import qualified Ui.Meter.Meter as Meter
import Ui.Meter.Meter (AbstractMeter(..))
import Global
data Meter = Meter {
Meter -> [Int]
meter_nums :: ![Int]
, Meter -> Duration
meter_denom :: !Duration
, Meter -> Ranks
meter_ranks :: !Ranks
} deriving (Meter -> Meter -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Meter -> Meter -> Bool
$c/= :: Meter -> Meter -> Bool
== :: Meter -> Meter -> Bool
$c== :: Meter -> Meter -> Bool
Eq, Int -> Meter -> ShowS
[Meter] -> ShowS
Meter -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Meter] -> ShowS
$cshowList :: [Meter] -> ShowS
show :: Meter -> String
$cshow :: Meter -> String
showsPrec :: Int -> Meter -> ShowS
$cshowsPrec :: Int -> Meter -> ShowS
Show)
type Ranks = Vector.Vector Rank
type Rank = Int
time_num :: Meter -> Int
time_num :: Meter -> Int
time_num = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. Meter -> [Int]
meter_nums
rank_at :: Meter -> Time -> Int
rank_at :: Meter -> Time -> Int
rank_at Meter
meter Time
t = Ranks
v forall a. Unbox a => Vector a -> Int -> a
! (Time -> Int
time_index Time
t forall a. Integral a => a -> a -> a
`mod` forall a. Unbox a => Vector a -> Int
Vector.length Ranks
v)
where v :: Ranks
v = Meter -> Ranks
meter_ranks Meter
meter
time_index :: Time -> Int
time_index :: Time -> Int
time_index = forall a b. (Integral a, Num b) => a -> b
fromIntegral
index_time :: Int -> Time
index_time :: Int -> Time
index_time = forall a b. (Integral a, Num b) => a -> b
fromIntegral
instance Pretty Meter where pretty :: Meter -> Text
pretty = Meter -> Text
unparse_meter
instance Types.ToLily Meter where
to_lily :: Meter -> Text
to_lily (Meter [Int]
nums Duration
denom Ranks
_) =
forall a. Show a => a -> Text
showt (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum [Int]
nums) forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> forall a. ToLily a => a -> Text
Types.to_lily Duration
denom
is_binary :: Meter -> Bool
is_binary :: Meter -> Bool
is_binary Meter
meter = case Meter -> [Int]
meter_nums Meter
meter of
[Int
num] -> (forall a. Eq a => a -> a -> Bool
==Double
0) forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction forall a b. (a -> b) -> a -> b
$ forall a. Floating a => a -> a -> a
logBase Double
2 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
num)
[Int]
_ -> Bool
False
measure_time :: Meter -> Time
measure_time :: Meter -> Time
measure_time Meter
meter =
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Meter -> Int
time_num Meter
meter) forall a. Num a => a -> a -> a
* Duration -> Time
Types.dur_to_time (Meter -> Duration
meter_denom Meter
meter)
unparse_meter :: Meter -> Text
unparse_meter :: Meter -> Text
unparse_meter Meter
meter = Text -> [Text] -> Text
Text.intercalate Text
"+" (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> Text
showt (Meter -> [Int]
meter_nums Meter
meter))
forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> forall a. ToLily a => a -> Text
Types.to_lily (Meter -> Duration
meter_denom Meter
meter)
default_meter :: Meter
Right Meter
default_meter = Text -> Either Text Meter
parse_meter Text
"4/4"
parse_meter :: Text -> Either Text Meter
parse_meter :: Text -> Either Text Meter
parse_meter Text
text = do
([Int]
nums, Int
denom) <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text
"parsing meter: "<>) forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Text -> Either Text a
Parse.parse Parser ([Int], Int)
p_meter Text
text
Duration
denom <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust (Text
"denominator not a valid duration: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
denom) forall a b. (a -> b) -> a -> b
$
Int -> Maybe Duration
Types.int_dur Int
denom
[Int] -> Duration -> [AbstractMeter] -> Either Text Meter
make_meter [Int]
nums Duration
denom ([Int] -> Duration -> [AbstractMeter]
abstract_meter [Int]
nums Duration
denom)
abstract_meter :: [Int] -> Duration -> [AbstractMeter]
abstract_meter :: [Int] -> Duration -> [AbstractMeter]
abstract_meter [Int]
nums Duration
denom = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ([Int]
nums, Duration
denom) Map ([Int], Duration) AbstractMeter
default_meters of
Just AbstractMeter
m -> [AbstractMeter
m]
Maybe AbstractMeter
Nothing -> case [Int] -> Duration -> [Int]
default_divisions [Int]
nums Duration
denom of
[Int
num] -> [[AbstractMeter] -> AbstractMeter
D (forall a. Int -> a -> [a]
replicate Int
num AbstractMeter
T)]
[Int]
nums -> [[AbstractMeter] -> AbstractMeter
D [[AbstractMeter] -> AbstractMeter
D (forall a. Int -> a -> [a]
replicate Int
n AbstractMeter
T) | Int
n <- [Int]
nums]]
where
default_meters :: Map ([Int], Duration) AbstractMeter
default_meters = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (([Int
1], Duration
D4), AbstractMeter
T)
, (([Int
2], Duration
D4), AbstractMeter
T)
, (([Int
4], Duration
D4), AbstractMeter
T)
]
default_divisions :: [Int] -> Duration -> [Int]
default_divisions :: [Int] -> Duration -> [Int]
default_divisions [Int
num] Duration
denom = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [Int
num] (Int
num, Duration
denom) Map (Int, Duration) [Int]
defaults
where
defaults :: Map (Int, Duration) [Int]
defaults = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ ((Int
5, Duration
D8), [Int
3, Int
2])
, ((Int
6, Duration
D8), [Int
3, Int
3])
, ((Int
7, Duration
D8), [Int
3, Int
4])
, ((Int
9, Duration
D8), [Int
3, Int
3, Int
3])
, ((Int
12, Duration
D8), [Int
3, Int
3, Int
3, Int
3])
]
default_divisions [Int]
nums Duration
_ = [Int]
nums
p_meter :: Parse.Parser ([Int], Int)
p_meter :: Parser ([Int], Int)
p_meter = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
P.sepBy1 forall (m :: * -> *). ParserT m Int
Parse.p_positive (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'+')
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
P.char Char
'/' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). ParserT m Int
Parse.p_positive)
make_meter :: [Int] -> Duration -> [AbstractMeter] -> Either Text Meter
make_meter :: [Int] -> Duration -> [AbstractMeter] -> Either Text Meter
make_meter [Int]
nums Duration
denom [AbstractMeter]
meters = [Int] -> Duration -> Ranks -> Meter
Meter [Int]
nums Duration
denom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text Ranks
vector
where
vector :: Either Text Ranks
vector
| Double
frac forall a. Eq a => a -> a -> Bool
/= Double
0 = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"can't fit " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
ranks forall a. Semigroup a => a -> a -> a
<> Text
" into "
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
expected forall a. Semigroup a => a -> a -> a
<> Text
" by doubling"
| Bool
otherwise = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ [AbstractMeter] -> Ranks
to_vector forall a b. (a -> b) -> a -> b
$ [Int] -> [AbstractMeter] -> [AbstractMeter]
subdivides (forall a. Int -> a -> [a]
replicate Int
exp Int
2) [AbstractMeter]
meters
(Int
exp, Double
frac) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction forall a b. (a -> b) -> a -> b
$
forall a. Floating a => a -> a -> a
logBase Double
2 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
expected forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ranks)
expected :: Int
expected = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum [Int]
nums forall a. Num a => a -> a -> a
* Time -> Int
time_index (Duration -> Time
Types.dur_to_time Duration
denom)
ranks :: Int
ranks = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map AbstractMeter -> Int
abstract_length [AbstractMeter]
meters
to_vector :: [AbstractMeter] -> Ranks
to_vector = forall a. Unbox a => [a] -> Vector a
Vector.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. Enum a => a -> Int
fromEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Duration, AbstractMeter)] -> [(Rank, Duration)]
Meter.Make.to_rank_durations forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Duration
1,)
subdivides :: [Int] -> [AbstractMeter] -> [AbstractMeter]
subdivides :: [Int] -> [AbstractMeter] -> [AbstractMeter]
subdivides [Int]
divs [AbstractMeter]
meter = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> [AbstractMeter] -> [AbstractMeter]
subdivide [AbstractMeter]
meter (forall a. [a] -> [a]
reverse [Int]
divs)
subdivide :: Int -> [AbstractMeter] -> [AbstractMeter]
subdivide :: Int -> [AbstractMeter] -> [AbstractMeter]
subdivide Int
n = forall a b. (a -> b) -> [a] -> [b]
map (Int -> AbstractMeter -> AbstractMeter
Meter.subdivide Int
n)
abstract_length :: AbstractMeter -> Int
abstract_length :: AbstractMeter -> Int
abstract_length (D [AbstractMeter]
ds) = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map AbstractMeter -> Int
abstract_length [AbstractMeter]
ds
abstract_length AbstractMeter
T = Int
1
allowed_duration :: Bool -> Meter -> Time -> Time -> NoteDuration
allowed_duration :: Bool -> Meter -> Time -> Time -> NoteDuration
allowed_duration Bool
use_dot Meter
meter Time
start_ Time
dur =
Time -> NoteDuration
best_duration forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a
min (Time
start forall a. Num a => a -> a -> a
+ Time
dur) forall a b. (a -> b) -> a -> b
$ Meter -> Time -> Time
allowed_time Meter
meter Time
start
where
best_duration :: Time -> NoteDuration
best_duration Time
end
| Just NoteDuration
ndur <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((forall a. Eq a => a -> a -> Bool
== Time
startforall a. Num a => a -> a -> a
+Time
dur) forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteDuration -> Time
to_time) [NoteDuration]
candidates = NoteDuration
ndur
| Bool
otherwise = forall a. a -> Maybe a -> a
fromMaybe (Duration -> Bool -> NoteDuration
Types.NoteDuration Duration
Types.D128 Bool
False) forall a b. (a -> b) -> a -> b
$
forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Lists.minimumOn (Meter -> Time -> Int
rank_at Meter
meter forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteDuration -> Time
to_time) [NoteDuration]
candidates
where
candidates :: [NoteDuration]
candidates = forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((forall a. Ord a => a -> a -> Bool
<=Time
end) forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteDuration -> Time
to_time) forall a b. (a -> b) -> a -> b
$
if Bool
use_dot then [NoteDuration]
dotted_durs else [NoteDuration]
durs
durs :: [NoteDuration]
durs = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip Duration -> Bool -> NoteDuration
NoteDuration Bool
False) [Duration
D1 .. Duration
D128]
dotted_durs :: [NoteDuration]
dotted_durs = forall a. [a] -> [a]
reverse
[Duration -> Bool -> NoteDuration
NoteDuration Duration
d Bool
dot | Duration
d <- [Duration
D1 .. Duration
D64], Bool
dot <- [Bool
True, Bool
False]]
start :: Time
start = Time
start_ forall a. Integral a => a -> a -> a
`mod` Meter -> Time
measure_time Meter
meter
to_time :: NoteDuration -> Time
to_time NoteDuration
dur = Time
start forall a. Num a => a -> a -> a
+ NoteDuration -> Time
Types.note_dur_to_time NoteDuration
dur
allowed_time :: Meter -> Time -> Time
allowed_time :: Meter -> Time -> Time
allowed_time Meter
meter Time
start = forall a. a -> Maybe a -> a
fromMaybe (Meter -> Time
measure_time Meter
meter) forall a b. (a -> b) -> a -> b
$ if Meter -> Bool
is_binary Meter
meter
then Int -> Maybe Time
at_rank (Int
start_rank forall a. Num a => a -> a -> a
- Int
2)
else case Int -> Maybe Time
at_rank (Int
start_rank forall a. Num a => a -> a -> a
- Int
1) of
Maybe Time
Nothing -> forall a. Maybe a
Nothing
Just Time
end -> forall a. Ord a => a -> a -> a
min (Time
start forall a. Num a => a -> a -> a
+ (Time
end forall a. Num a => a -> a -> a
- Time
start) forall a. Num a => a -> a -> a
* Time
2) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Maybe Time
at_rank (Int
start_rank forall a. Num a => a -> a -> a
- Int
2)
where
at_rank :: Int -> Maybe Time
at_rank Int
n = Time -> Int -> Meter -> Maybe Time
find_rank Time
start Int
n Meter
meter
start_rank :: Int
start_rank = Meter -> Time -> Int
rank_at Meter
meter Time
start
find_rank :: Time -> Rank -> Meter -> Maybe Time
find_rank :: Time -> Int -> Meter -> Maybe Time
find_rank Time
start Int
rank = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall a. Num a => a -> a -> a
+ (Time
start forall a. Num a => a -> a -> a
+ Time
1)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Time
index_time)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Unbox a => (a -> Bool) -> Vector a -> Maybe Int
Vector.findIndex (forall a. Ord a => a -> a -> Bool
<= forall a. Ord a => a -> a -> a
max Int
0 Int
rank)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Unbox a => Int -> Vector a -> Vector a
Vector.drop (Time -> Int
time_index Time
start forall a. Num a => a -> a -> a
+ Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Meter -> Ranks
meter_ranks