module Perform.Lilypond.Types where
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Util.Lens as Lens
import qualified Util.Pretty as Pretty
import qualified Derive.Attrs as Attrs
import qualified Derive.DeriveT as DeriveT
import qualified Derive.EnvKey as EnvKey
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Stack as Stack
import qualified Perform.Pitch as Pitch
import qualified Perform.RealTime as RealTime
import Global
import Types
class ToLily a where
to_lily :: a -> Text
instance ToLily Text where
to_lily :: Text -> Text
to_lily Text
txt = Text
"\"" forall a. Semigroup a => a -> a -> a
<> HasCallStack => Text -> Text -> Text -> Text
Text.replace Text
"\"" Text
"\\\"" Text
txt forall a. Semigroup a => a -> a -> a
<> Text
"\""
data Config = Config {
Config -> RealTime
config_quarter_duration :: !RealTime
, Config -> Duration
config_quantize :: !Duration
, Config -> Bool
config_dotted_rests :: !Bool
, Config -> [(Instrument, StaffConfig)]
config_staves :: ![(ScoreT.Instrument, StaffConfig)]
} deriving (Config -> Config -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c== :: Config -> Config -> Bool
Eq, ReadPrec [Config]
ReadPrec Config
Int -> ReadS Config
ReadS [Config]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Config]
$creadListPrec :: ReadPrec [Config]
readPrec :: ReadPrec Config
$creadPrec :: ReadPrec Config
readList :: ReadS [Config]
$creadList :: ReadS [Config]
readsPrec :: Int -> ReadS Config
$creadsPrec :: Int -> ReadS Config
Read, Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show)
quarter_duration :: Config :-> RealTime
quarter_duration = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Config -> RealTime
config_quarter_duration
(\RealTime -> RealTime
f Config
r -> Config
r { config_quarter_duration :: RealTime
config_quarter_duration = RealTime -> RealTime
f (Config -> RealTime
config_quarter_duration Config
r) })
quantize :: Config :-> Duration
quantize = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Config -> Duration
config_quantize
(\Duration -> Duration
f Config
r -> Config
r { config_quantize :: Duration
config_quantize = Duration -> Duration
f (Config -> Duration
config_quantize Config
r) })
dotted_rests :: Config :-> Bool
dotted_rests = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Config -> Bool
config_dotted_rests
(\Bool -> Bool
f Config
r -> Config
r { config_dotted_rests :: Bool
config_dotted_rests = Bool -> Bool
f (Config -> Bool
config_dotted_rests Config
r) })
staves :: Config :-> [(Instrument, StaffConfig)]
staves = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens Config -> [(Instrument, StaffConfig)]
config_staves
(\[(Instrument, StaffConfig)] -> [(Instrument, StaffConfig)]
f Config
r -> Config
r { config_staves :: [(Instrument, StaffConfig)]
config_staves = [(Instrument, StaffConfig)] -> [(Instrument, StaffConfig)]
f (Config -> [(Instrument, StaffConfig)]
config_staves Config
r) })
data StaffConfig = StaffConfig {
StaffConfig -> Text
staff_long :: !Instrument
, StaffConfig -> Text
staff_short :: !Instrument
, StaffConfig -> [Text]
staff_code :: ![Text]
, StaffConfig -> Bool
staff_display :: !Bool
, StaffConfig -> Bool
staff_add_bass_staff :: !Bool
} deriving (StaffConfig -> StaffConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StaffConfig -> StaffConfig -> Bool
$c/= :: StaffConfig -> StaffConfig -> Bool
== :: StaffConfig -> StaffConfig -> Bool
$c== :: StaffConfig -> StaffConfig -> Bool
Eq, ReadPrec [StaffConfig]
ReadPrec StaffConfig
Int -> ReadS StaffConfig
ReadS [StaffConfig]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [StaffConfig]
$creadListPrec :: ReadPrec [StaffConfig]
readPrec :: ReadPrec StaffConfig
$creadPrec :: ReadPrec StaffConfig
readList :: ReadS [StaffConfig]
$creadList :: ReadS [StaffConfig]
readsPrec :: Int -> ReadS StaffConfig
$creadsPrec :: Int -> ReadS StaffConfig
Read, Int -> StaffConfig -> ShowS
[StaffConfig] -> ShowS
StaffConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StaffConfig] -> ShowS
$cshowList :: [StaffConfig] -> ShowS
show :: StaffConfig -> String
$cshow :: StaffConfig -> String
showsPrec :: Int -> StaffConfig -> ShowS
$cshowsPrec :: Int -> StaffConfig -> ShowS
Show)
long :: StaffConfig :-> Text
long = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens StaffConfig -> Text
staff_long (\Text -> Text
f StaffConfig
r -> StaffConfig
r { staff_long :: Text
staff_long = Text -> Text
f (StaffConfig -> Text
staff_long StaffConfig
r) })
short :: StaffConfig :-> Text
short = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens StaffConfig -> Text
staff_short (\Text -> Text
f StaffConfig
r -> StaffConfig
r { staff_short :: Text
staff_short = Text -> Text
f (StaffConfig -> Text
staff_short StaffConfig
r) })
code :: StaffConfig :-> [Text]
code = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens StaffConfig -> [Text]
staff_code (\[Text] -> [Text]
f StaffConfig
r -> StaffConfig
r { staff_code :: [Text]
staff_code = [Text] -> [Text]
f (StaffConfig -> [Text]
staff_code StaffConfig
r) })
display :: StaffConfig :-> Bool
display = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens StaffConfig -> Bool
staff_display
(\Bool -> Bool
f StaffConfig
r -> StaffConfig
r { staff_display :: Bool
staff_display = Bool -> Bool
f (StaffConfig -> Bool
staff_display StaffConfig
r) })
add_bass_staff :: StaffConfig :-> Bool
add_bass_staff = forall f a. (f -> a) -> ((a -> a) -> f -> f) -> f :-> a
Lens.lens StaffConfig -> Bool
staff_add_bass_staff
(\Bool -> Bool
f StaffConfig
r -> StaffConfig
r { staff_add_bass_staff :: Bool
staff_add_bass_staff = Bool -> Bool
f (StaffConfig -> Bool
staff_add_bass_staff StaffConfig
r) })
type Instrument = Text
instance Pretty Config where
format :: Config -> Doc
format (Config RealTime
quarter Duration
quantize Bool
dotted [(Instrument, StaffConfig)]
staves) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Config"
[ (Text
"quarter_duration", forall a. Pretty a => a -> Doc
Pretty.format RealTime
quarter)
, (Text
"quantize", forall a. Pretty a => a -> Doc
Pretty.format Duration
quantize)
, (Text
"dotted_rests", forall a. Pretty a => a -> Doc
Pretty.format Bool
dotted)
, (Text
"staves", forall a. Pretty a => a -> Doc
Pretty.format [(Instrument, StaffConfig)]
staves)
]
instance Pretty StaffConfig where
format :: StaffConfig -> Doc
format (StaffConfig Text
long Text
short [Text]
code Bool
display Bool
add_bass) =
Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"StaffConfig"
[ (Text
"long", forall a. Pretty a => a -> Doc
Pretty.format Text
long)
, (Text
"short", forall a. Pretty a => a -> Doc
Pretty.format Text
short)
, (Text
"code", forall a. Pretty a => a -> Doc
Pretty.format [Text]
code)
, (Text
"display", forall a. Pretty a => a -> Doc
Pretty.format Bool
display)
, (Text
"add_bass_staff", forall a. Pretty a => a -> Doc
Pretty.format Bool
add_bass)
]
default_config :: Config
default_config :: Config
default_config = Config
{ config_quarter_duration :: RealTime
config_quarter_duration = RealTime
1
, config_quantize :: Duration
config_quantize = Duration
D32
, config_dotted_rests :: Bool
config_dotted_rests = Bool
False
, config_staves :: [(Instrument, StaffConfig)]
config_staves = []
}
empty_staff_config :: StaffConfig
empty_staff_config :: StaffConfig
empty_staff_config = StaffConfig
{ staff_long :: Text
staff_long = Text
""
, staff_short :: Text
staff_short = Text
""
, staff_code :: [Text]
staff_code = []
, staff_display :: Bool
staff_display = Bool
True
, staff_add_bass_staff :: Bool
staff_add_bass_staff = Bool
False
}
default_staff_config :: ScoreT.Instrument -> StaffConfig
default_staff_config :: Instrument -> StaffConfig
default_staff_config Instrument
inst =
StaffConfig
empty_staff_config { staff_long :: Text
staff_long = Instrument -> Text
ScoreT.instrument_name Instrument
inst }
global_staff_code :: [Text]
global_staff_code :: [Text]
global_staff_code =
[ Text
"\\numericTimeSignature"
, Text
"\\set Staff.printKeyCancellation = ##f"
, Text
"\\override Score.BarNumber.break-visibility = ##(#f #t #t)"
]
data Duration = D1 | D2 | D4 | D8 | D16 | D32 | D64 | D128
deriving (Int -> Duration
Duration -> Int
Duration -> [Duration]
Duration -> Duration
Duration -> Duration -> [Duration]
Duration -> Duration -> Duration -> [Duration]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Duration -> Duration -> Duration -> [Duration]
$cenumFromThenTo :: Duration -> Duration -> Duration -> [Duration]
enumFromTo :: Duration -> Duration -> [Duration]
$cenumFromTo :: Duration -> Duration -> [Duration]
enumFromThen :: Duration -> Duration -> [Duration]
$cenumFromThen :: Duration -> Duration -> [Duration]
enumFrom :: Duration -> [Duration]
$cenumFrom :: Duration -> [Duration]
fromEnum :: Duration -> Int
$cfromEnum :: Duration -> Int
toEnum :: Int -> Duration
$ctoEnum :: Int -> Duration
pred :: Duration -> Duration
$cpred :: Duration -> Duration
succ :: Duration -> Duration
$csucc :: Duration -> Duration
Enum, Duration
forall a. a -> a -> Bounded a
maxBound :: Duration
$cmaxBound :: Duration
minBound :: Duration
$cminBound :: Duration
Bounded, Duration -> Duration -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Duration -> Duration -> Bool
$c/= :: Duration -> Duration -> Bool
== :: Duration -> Duration -> Bool
$c== :: Duration -> Duration -> Bool
Eq, Eq Duration
Duration -> Duration -> Bool
Duration -> Duration -> Ordering
Duration -> Duration -> Duration
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Duration -> Duration -> Duration
$cmin :: Duration -> Duration -> Duration
max :: Duration -> Duration -> Duration
$cmax :: Duration -> Duration -> Duration
>= :: Duration -> Duration -> Bool
$c>= :: Duration -> Duration -> Bool
> :: Duration -> Duration -> Bool
$c> :: Duration -> Duration -> Bool
<= :: Duration -> Duration -> Bool
$c<= :: Duration -> Duration -> Bool
< :: Duration -> Duration -> Bool
$c< :: Duration -> Duration -> Bool
compare :: Duration -> Duration -> Ordering
$ccompare :: Duration -> Duration -> Ordering
Ord, ReadPrec [Duration]
ReadPrec Duration
Int -> ReadS Duration
ReadS [Duration]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Duration]
$creadListPrec :: ReadPrec [Duration]
readPrec :: ReadPrec Duration
$creadPrec :: ReadPrec Duration
readList :: ReadS [Duration]
$creadList :: ReadS [Duration]
readsPrec :: Int -> ReadS Duration
$creadsPrec :: Int -> ReadS Duration
Read, Int -> Duration -> ShowS
[Duration] -> ShowS
Duration -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Duration] -> ShowS
$cshowList :: [Duration] -> ShowS
show :: Duration -> String
$cshow :: Duration -> String
showsPrec :: Int -> Duration -> ShowS
$cshowsPrec :: Int -> Duration -> ShowS
Show)
instance Pretty Duration where pretty :: Duration -> Text
pretty = forall a. Show a => a -> Text
showt
instance ToLily Duration where to_lily :: Duration -> Text
to_lily = String -> Text
txt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
dur_char :: Duration -> Char
dur_char :: Duration -> Char
dur_char Duration
d = case Duration
d of
Duration
D1 -> Char
'w'; Duration
D2 -> Char
'h'; Duration
D4 -> Char
'q'; Duration
D8 -> Char
'e'
Duration
D16 -> Char
's'; Duration
D32 -> Char
't'; Duration
D64 -> Char
'y'; Duration
D128 -> Char
'z'
int_dur :: Int -> Maybe Duration
int_dur :: Int -> Maybe Duration
int_dur Int
i = case Int
i of
Int
1 -> forall a. a -> Maybe a
Just Duration
D1; Int
2 -> forall a. a -> Maybe a
Just Duration
D2; Int
4 -> forall a. a -> Maybe a
Just Duration
D4; Int
8 -> forall a. a -> Maybe a
Just Duration
D8
Int
16 -> forall a. a -> Maybe a
Just Duration
D16; Int
32 -> forall a. a -> Maybe a
Just Duration
D32; Int
64 -> forall a. a -> Maybe a
Just Duration
D64; Int
128 -> forall a. a -> Maybe a
Just Duration
D128
Int
_ -> forall a. Maybe a
Nothing
dur_to_time :: Duration -> Time
dur_to_time :: Duration -> Time
dur_to_time Duration
dur = Int -> Time
Time forall a b. (a -> b) -> a -> b
$ case Duration
dur of
Duration
D1 -> Int
128; Duration
D2 -> Int
64; Duration
D4 -> Int
32; Duration
D8 -> Int
16
Duration
D16 -> Int
8; Duration
D32 -> Int
4; Duration
D64 -> Int
2; Duration
D128 -> Int
1
time_to_dur :: Time -> Duration
time_to_dur :: Time -> Duration
time_to_dur (Time Int
t)
| Int
t forall a. Ord a => a -> a -> Bool
< Int
2 = Duration
D128
| Int
t forall a. Ord a => a -> a -> Bool
< Int
4 = Duration
D64
| Int
t forall a. Ord a => a -> a -> Bool
< Int
8 = Duration
D32
| Int
t forall a. Ord a => a -> a -> Bool
< Int
16 = Duration
D16
| Int
t forall a. Ord a => a -> a -> Bool
< Int
32 = Duration
D8
| Int
t forall a. Ord a => a -> a -> Bool
< Int
64 = Duration
D4
| Int
t forall a. Ord a => a -> a -> Bool
< Int
128 = Duration
D2
| Bool
otherwise = Duration
D1
time_to_durs :: Time -> [Duration]
time_to_durs :: Time -> [Duration]
time_to_durs Time
time = Duration -> Time -> [Duration]
go Duration
D1 Time
time
where
go :: Duration -> Time -> [Duration]
go Duration
dur Time
time
| Time
time forall a. Ord a => a -> a -> Bool
>= Duration -> Time
dur_to_time Duration
dur = Duration
dur forall a. a -> [a] -> [a]
: Duration -> Time -> [Duration]
go Duration
dur (Time
time forall a. Num a => a -> a -> a
- Duration -> Time
dur_to_time Duration
dur)
| Duration
dur forall a. Eq a => a -> a -> Bool
== Duration
D128 = []
| Bool
otherwise = Duration -> Time -> [Duration]
go (forall a. Enum a => a -> a
succ Duration
dur) Time
time
data NoteDuration = NoteDuration !Duration !Bool
deriving (NoteDuration -> NoteDuration -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoteDuration -> NoteDuration -> Bool
$c/= :: NoteDuration -> NoteDuration -> Bool
== :: NoteDuration -> NoteDuration -> Bool
$c== :: NoteDuration -> NoteDuration -> Bool
Eq, Int -> NoteDuration -> ShowS
[NoteDuration] -> ShowS
NoteDuration -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoteDuration] -> ShowS
$cshowList :: [NoteDuration] -> ShowS
show :: NoteDuration -> String
$cshow :: NoteDuration -> String
showsPrec :: Int -> NoteDuration -> ShowS
$cshowsPrec :: Int -> NoteDuration -> ShowS
Show)
instance ToLily NoteDuration where
to_lily :: NoteDuration -> Text
to_lily (NoteDuration Duration
dur Bool
dot) = forall a. ToLily a => a -> Text
to_lily Duration
dur forall a. Semigroup a => a -> a -> a
<> if Bool
dot then Text
"." else Text
""
instance Pretty NoteDuration where pretty :: NoteDuration -> Text
pretty = (Text
"D"<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToLily a => a -> Text
to_lily
note_dur_char :: NoteDuration -> Text
note_dur_char :: NoteDuration -> Text
note_dur_char (NoteDuration Duration
dur Bool
dotted) =
Char -> Text
Text.singleton (Duration -> Char
dur_char Duration
dur) forall a. Semigroup a => a -> a -> a
<> if Bool
dotted then Text
"." else Text
""
note_dur_to_time :: NoteDuration -> Time
note_dur_to_time :: NoteDuration -> Time
note_dur_to_time (NoteDuration Duration
dur Bool
dotted) =
Duration -> Time
dur_to_time Duration
dur forall a. Num a => a -> a -> a
+ if Bool
dotted Bool -> Bool -> Bool
&& Duration
dur forall a. Eq a => a -> a -> Bool
/= Duration
D128 then Duration -> Time
dur_to_time (forall a. Enum a => a -> a
succ Duration
dur)
else Time
0
time_to_note_dur :: Time -> NoteDuration
time_to_note_dur :: Time -> NoteDuration
time_to_note_dur Time
t = case Time -> [Duration]
time_to_durs Time
t of
[Duration
d1, Duration
d2] | Duration
d2 forall a. Eq a => a -> a -> Bool
== forall a. Enum a => a -> a
succ Duration
d1 -> Duration -> Bool -> NoteDuration
NoteDuration Duration
d1 Bool
True
Duration
d : [Duration]
_ -> Duration -> Bool -> NoteDuration
NoteDuration Duration
d Bool
False
[] -> Duration -> Bool -> NoteDuration
NoteDuration Duration
D128 Bool
False
dur_to_note_dur :: Duration -> NoteDuration
dur_to_note_dur :: Duration -> NoteDuration
dur_to_note_dur Duration
d = Duration -> Bool -> NoteDuration
NoteDuration Duration
d Bool
False
is_note_dur :: Time -> Maybe NoteDuration
is_note_dur :: Time -> Maybe NoteDuration
is_note_dur Time
t = case Time -> [NoteDuration]
time_to_note_durs Time
t of
[NoteDuration
d] -> forall a. a -> Maybe a
Just NoteDuration
d
[NoteDuration]
_ -> forall a. Maybe a
Nothing
time_to_note_durs :: Time -> [NoteDuration]
time_to_note_durs :: Time -> [NoteDuration]
time_to_note_durs Time
t
| Time
t forall a. Ord a => a -> a -> Bool
> Time
0 = NoteDuration
dur forall a. a -> [a] -> [a]
: Time -> [NoteDuration]
time_to_note_durs (Time
t forall a. Num a => a -> a -> a
- NoteDuration -> Time
note_dur_to_time NoteDuration
dur)
| Bool
otherwise = []
where dur :: NoteDuration
dur = Time -> NoteDuration
time_to_note_dur Time
t
newtype Time = Time Int deriving (Time -> Time -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Time -> Time -> Bool
$c/= :: Time -> Time -> Bool
== :: Time -> Time -> Bool
$c== :: Time -> Time -> Bool
Eq, Eq Time
Time -> Time -> Bool
Time -> Time -> Ordering
Time -> Time -> Time
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Time -> Time -> Time
$cmin :: Time -> Time -> Time
max :: Time -> Time -> Time
$cmax :: Time -> Time -> Time
>= :: Time -> Time -> Bool
$c>= :: Time -> Time -> Bool
> :: Time -> Time -> Bool
$c> :: Time -> Time -> Bool
<= :: Time -> Time -> Bool
$c<= :: Time -> Time -> Bool
< :: Time -> Time -> Bool
$c< :: Time -> Time -> Bool
compare :: Time -> Time -> Ordering
$ccompare :: Time -> Time -> Ordering
Ord, Int -> Time -> ShowS
[Time] -> ShowS
Time -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Time] -> ShowS
$cshowList :: [Time] -> ShowS
show :: Time -> String
$cshow :: Time -> String
showsPrec :: Int -> Time -> ShowS
$cshowsPrec :: Int -> Time -> ShowS
Show, Integer -> Time
Time -> Time
Time -> Time -> Time
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Time
$cfromInteger :: Integer -> Time
signum :: Time -> Time
$csignum :: Time -> Time
abs :: Time -> Time
$cabs :: Time -> Time
negate :: Time -> Time
$cnegate :: Time -> Time
* :: Time -> Time -> Time
$c* :: Time -> Time -> Time
- :: Time -> Time -> Time
$c- :: Time -> Time -> Time
+ :: Time -> Time -> Time
$c+ :: Time -> Time -> Time
Num, Int -> Time
Time -> Int
Time -> [Time]
Time -> Time
Time -> Time -> [Time]
Time -> Time -> Time -> [Time]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Time -> Time -> Time -> [Time]
$cenumFromThenTo :: Time -> Time -> Time -> [Time]
enumFromTo :: Time -> Time -> [Time]
$cenumFromTo :: Time -> Time -> [Time]
enumFromThen :: Time -> Time -> [Time]
$cenumFromThen :: Time -> Time -> [Time]
enumFrom :: Time -> [Time]
$cenumFrom :: Time -> [Time]
fromEnum :: Time -> Int
$cfromEnum :: Time -> Int
toEnum :: Int -> Time
$ctoEnum :: Int -> Time
pred :: Time -> Time
$cpred :: Time -> Time
succ :: Time -> Time
$csucc :: Time -> Time
Enum, Num Time
Ord Time
Time -> Rational
forall a. Num a -> Ord a -> (a -> Rational) -> Real a
toRational :: Time -> Rational
$ctoRational :: Time -> Rational
Real, Enum Time
Real Time
Time -> Integer
Time -> Time -> (Time, Time)
Time -> Time -> Time
forall a.
Real a
-> Enum a
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
toInteger :: Time -> Integer
$ctoInteger :: Time -> Integer
divMod :: Time -> Time -> (Time, Time)
$cdivMod :: Time -> Time -> (Time, Time)
quotRem :: Time -> Time -> (Time, Time)
$cquotRem :: Time -> Time -> (Time, Time)
mod :: Time -> Time -> Time
$cmod :: Time -> Time -> Time
div :: Time -> Time -> Time
$cdiv :: Time -> Time -> Time
rem :: Time -> Time -> Time
$crem :: Time -> Time -> Time
quot :: Time -> Time -> Time
$cquot :: Time -> Time -> Time
Integral)
instance Pretty Time where pretty :: Time -> Text
pretty = forall a. Pretty a => a -> Text
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. Time -> Rational
to_whole
to_whole :: Time -> Rational
to_whole :: Time -> Rational
to_whole Time
t = forall a b. (Integral a, Num b) => a -> b
fromIntegral Time
t forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Time
time_per_whole
time_per_whole :: Time
time_per_whole :: Time
time_per_whole = Duration -> Time
dur_to_time Duration
D1
real_to_time :: RealTime -> RealTime -> Time
real_to_time :: RealTime -> RealTime -> Time
real_to_time RealTime
quarter = Int -> Time
Time forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double
adjust forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Double
RealTime.to_seconds
where
adjust :: Double -> Double
adjust Double
n = Double
n forall a. Num a => a -> a -> a
* (Double
1 forall a. Fractional a => a -> a -> a
/ RealTime -> Double
RealTime.to_seconds RealTime
quarter forall a. Num a => a -> a -> a
* Double
qtime)
qtime :: Double
qtime = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Duration -> Time
dur_to_time Duration
D4)
multiply :: Rational -> Time -> Maybe Time
multiply :: Rational -> Time -> Maybe Time
multiply Rational
factor Time
t
| Rational
frac forall a. Eq a => a -> a -> Bool
== Rational
0 = forall a. a -> Maybe a
Just (Int -> Time
Time Int
i)
| Bool
otherwise = forall a. Maybe a
Nothing
where (Int
i, Rational
frac) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction (forall a b. (Integral a, Num b) => a -> b
fromIntegral Time
t forall a. Num a => a -> a -> a
* Rational
factor)
multiply_int :: Int -> Time -> Time
multiply_int :: Int -> Time -> Time
multiply_int Int
factor (Time Int
t) = Int -> Time
Time (Int
t forall a. Num a => a -> a -> a
* Int
factor)
data Event = Event {
Event -> Time
event_start :: !Time
, Event -> Time
event_duration :: !Time
, Event -> Maybe Pitch
event_pitch :: !(Maybe Pitch)
, Event -> Instrument
event_instrument :: !ScoreT.Instrument
, Event -> Environ
event_environ :: !DeriveT.Environ
, Event -> Stack
event_stack :: !Stack.Stack
, Event -> Bool
event_clipped :: !Bool
} deriving (Int -> Event -> ShowS
[Event] -> ShowS
Event -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Event] -> ShowS
$cshowList :: [Event] -> ShowS
show :: Event -> String
$cshow :: Event -> String
showsPrec :: Int -> Event -> ShowS
$cshowsPrec :: Int -> Event -> ShowS
Show)
event_end :: Event -> Time
event_end :: Event -> Time
event_end Event
event = Event -> Time
event_start Event
event forall a. Num a => a -> a -> a
+ Event -> Time
event_duration Event
event
event_overlaps :: Event -> Event -> Bool
event_overlaps :: Event -> Event -> Bool
event_overlaps Event
e1 Event
e2 =
Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Event -> Time
event_end Event
e1 forall a. Ord a => a -> a -> Bool
<= Event -> Time
event_start Event
e2 Bool -> Bool -> Bool
|| Event -> Time
event_start Event
e1 forall a. Ord a => a -> a -> Bool
>= Event -> Time
event_end Event
e2
event_attributes :: Event -> Attrs.Attributes
event_attributes :: Event -> Attributes
event_attributes = Environ -> Attributes
DeriveT.environ_attributes forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> Environ
event_environ
instance Pretty Event where
format :: Event -> Doc
format (Event Time
start Time
dur Maybe Pitch
pitch Instrument
inst Environ
env_ Stack
_stack Bool
_clipped) =
Text -> [Doc] -> Doc
Pretty.constructor Text
"Event" forall a b. (a -> b) -> a -> b
$
[ forall a. Pretty a => a -> Doc
Pretty.format Time
start, forall a. Pretty a => a -> Doc
Pretty.format Time
dur
, forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
"rest" (Text -> Doc
Pretty.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToLily a => a -> Text
to_lily) Maybe Pitch
pitch, forall a. Pretty a => a -> Doc
Pretty.format Instrument
inst
] forall a. [a] -> [a] -> [a]
++ if forall k a. Map k a -> Bool
Map.null Map Text Val
e then [] else [forall a. Pretty a => a -> Doc
Pretty.format Environ
env]
where env :: Environ
env@(DeriveT.Environ Map Text Val
e) = Environ -> Environ
strip_environ Environ
env_
strip_environ :: DeriveT.Environ -> DeriveT.Environ
strip_environ :: Environ -> Environ
strip_environ (DeriveT.Environ Map Text Val
env) =
Map Text Val -> Environ
DeriveT.Environ forall a b. (a -> b) -> a -> b
$ forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey Text -> Val -> Bool
interesting Map Text Val
env
where
interesting :: Text -> Val -> Bool
interesting Text
key Val
val = Text
"ly-" Text -> Text -> Bool
`Text.isPrefixOf` Text
key
Bool -> Bool -> Bool
|| (Text
key forall a. Eq a => a -> a -> Bool
== Text
EnvKey.attributes Bool -> Bool -> Bool
&& Val -> Bool
has_attrs Val
val)
Bool -> Bool -> Bool
|| Text
key forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
EnvKey.voice, Text
EnvKey.hand]
has_attrs :: Val -> Bool
has_attrs (DeriveT.VAttributes Attributes
attrs) = Attributes
attrs forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty
has_attrs Val
_ = Bool
True
data Pitch = Pitch !Int !PitchClass !Accidental
deriving (Pitch -> Pitch -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pitch -> Pitch -> Bool
$c/= :: Pitch -> Pitch -> Bool
== :: Pitch -> Pitch -> Bool
$c== :: Pitch -> Pitch -> Bool
Eq, Int -> Pitch -> ShowS
[Pitch] -> ShowS
Pitch -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pitch] -> ShowS
$cshowList :: [Pitch] -> ShowS
show :: Pitch -> String
$cshow :: Pitch -> String
showsPrec :: Int -> Pitch -> ShowS
$cshowsPrec :: Int -> Pitch -> ShowS
Show, Eq Pitch
Pitch -> Pitch -> Bool
Pitch -> Pitch -> Ordering
Pitch -> Pitch -> Pitch
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Pitch -> Pitch -> Pitch
$cmin :: Pitch -> Pitch -> Pitch
max :: Pitch -> Pitch -> Pitch
$cmax :: Pitch -> Pitch -> Pitch
>= :: Pitch -> Pitch -> Bool
$c>= :: Pitch -> Pitch -> Bool
> :: Pitch -> Pitch -> Bool
$c> :: Pitch -> Pitch -> Bool
<= :: Pitch -> Pitch -> Bool
$c<= :: Pitch -> Pitch -> Bool
< :: Pitch -> Pitch -> Bool
$c< :: Pitch -> Pitch -> Bool
compare :: Pitch -> Pitch -> Ordering
$ccompare :: Pitch -> Pitch -> Ordering
Ord)
data PitchClass = C | D | E | F | G | A | B
deriving (PitchClass -> PitchClass -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PitchClass -> PitchClass -> Bool
$c/= :: PitchClass -> PitchClass -> Bool
== :: PitchClass -> PitchClass -> Bool
$c== :: PitchClass -> PitchClass -> Bool
Eq, Int -> PitchClass -> ShowS
[PitchClass] -> ShowS
PitchClass -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PitchClass] -> ShowS
$cshowList :: [PitchClass] -> ShowS
show :: PitchClass -> String
$cshow :: PitchClass -> String
showsPrec :: Int -> PitchClass -> ShowS
$cshowsPrec :: Int -> PitchClass -> ShowS
Show, Eq PitchClass
PitchClass -> PitchClass -> Bool
PitchClass -> PitchClass -> Ordering
PitchClass -> PitchClass -> PitchClass
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PitchClass -> PitchClass -> PitchClass
$cmin :: PitchClass -> PitchClass -> PitchClass
max :: PitchClass -> PitchClass -> PitchClass
$cmax :: PitchClass -> PitchClass -> PitchClass
>= :: PitchClass -> PitchClass -> Bool
$c>= :: PitchClass -> PitchClass -> Bool
> :: PitchClass -> PitchClass -> Bool
$c> :: PitchClass -> PitchClass -> Bool
<= :: PitchClass -> PitchClass -> Bool
$c<= :: PitchClass -> PitchClass -> Bool
< :: PitchClass -> PitchClass -> Bool
$c< :: PitchClass -> PitchClass -> Bool
compare :: PitchClass -> PitchClass -> Ordering
$ccompare :: PitchClass -> PitchClass -> Ordering
Ord, Int -> PitchClass
PitchClass -> Int
PitchClass -> [PitchClass]
PitchClass -> PitchClass
PitchClass -> PitchClass -> [PitchClass]
PitchClass -> PitchClass -> PitchClass -> [PitchClass]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: PitchClass -> PitchClass -> PitchClass -> [PitchClass]
$cenumFromThenTo :: PitchClass -> PitchClass -> PitchClass -> [PitchClass]
enumFromTo :: PitchClass -> PitchClass -> [PitchClass]
$cenumFromTo :: PitchClass -> PitchClass -> [PitchClass]
enumFromThen :: PitchClass -> PitchClass -> [PitchClass]
$cenumFromThen :: PitchClass -> PitchClass -> [PitchClass]
enumFrom :: PitchClass -> [PitchClass]
$cenumFrom :: PitchClass -> [PitchClass]
fromEnum :: PitchClass -> Int
$cfromEnum :: PitchClass -> Int
toEnum :: Int -> PitchClass
$ctoEnum :: Int -> PitchClass
pred :: PitchClass -> PitchClass
$cpred :: PitchClass -> PitchClass
succ :: PitchClass -> PitchClass
$csucc :: PitchClass -> PitchClass
Enum)
data Accidental = FlatFlat | Flat | Natural | Sharp | SharpSharp
deriving (Accidental -> Accidental -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Accidental -> Accidental -> Bool
$c/= :: Accidental -> Accidental -> Bool
== :: Accidental -> Accidental -> Bool
$c== :: Accidental -> Accidental -> Bool
Eq, Int -> Accidental -> ShowS
[Accidental] -> ShowS
Accidental -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Accidental] -> ShowS
$cshowList :: [Accidental] -> ShowS
show :: Accidental -> String
$cshow :: Accidental -> String
showsPrec :: Int -> Accidental -> ShowS
$cshowsPrec :: Int -> Accidental -> ShowS
Show, Eq Accidental
Accidental -> Accidental -> Bool
Accidental -> Accidental -> Ordering
Accidental -> Accidental -> Accidental
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Accidental -> Accidental -> Accidental
$cmin :: Accidental -> Accidental -> Accidental
max :: Accidental -> Accidental -> Accidental
$cmax :: Accidental -> Accidental -> Accidental
>= :: Accidental -> Accidental -> Bool
$c>= :: Accidental -> Accidental -> Bool
> :: Accidental -> Accidental -> Bool
$c> :: Accidental -> Accidental -> Bool
<= :: Accidental -> Accidental -> Bool
$c<= :: Accidental -> Accidental -> Bool
< :: Accidental -> Accidental -> Bool
$c< :: Accidental -> Accidental -> Bool
compare :: Accidental -> Accidental -> Ordering
$ccompare :: Accidental -> Accidental -> Ordering
Ord)
instance Pretty Pitch where pretty :: Pitch -> Text
pretty = forall a. ToLily a => a -> Text
to_lily
instance ToLily Pitch where
to_lily :: Pitch -> Text
to_lily (Pitch Int
octave PitchClass
pc Accidental
acc) = forall a. ToLily a => a -> Text
to_lily PitchClass
pc forall a. Semigroup a => a -> a -> a
<> forall a. ToLily a => a -> Text
to_lily Accidental
acc forall a. Semigroup a => a -> a -> a
<> Text
oct_mark
where
oct_mark :: Text
oct_mark
| Int
oct forall a. Ord a => a -> a -> Bool
>= Int
0 = Int -> Text -> Text
Text.replicate Int
oct Text
"'"
| Bool
otherwise = Int -> Text -> Text
Text.replicate (forall a. Num a => a -> a
abs Int
oct) Text
","
where oct :: Int
oct = Int
octave forall a. Num a => a -> a -> a
- Int
3
instance ToLily PitchClass where
to_lily :: PitchClass -> Text
to_lily PitchClass
pc = case PitchClass
pc of
PitchClass
C -> Text
"c"; PitchClass
D -> Text
"d"; PitchClass
E -> Text
"e"; PitchClass
F -> Text
"f"
PitchClass
G -> Text
"g"; PitchClass
A -> Text
"a"; PitchClass
B -> Text
"b"
instance ToLily Accidental where
to_lily :: Accidental -> Text
to_lily Accidental
acc = case Accidental
acc of
Accidental
FlatFlat -> Text
"ff"
Accidental
Flat -> Text
"f"
Accidental
Natural -> Text
""
Accidental
Sharp -> Text
"s"
Accidental
SharpSharp -> Text
"ss"
parse_pitch :: Pitch.Pitch -> Either Text Pitch
parse_pitch :: Pitch -> Either Text Pitch
parse_pitch (Pitch.Pitch Int
octave Degree
degree) =
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Int -> PitchClass -> Accidental -> Pitch
Pitch Int
octave) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Degree -> Either Text (PitchClass, Accidental)
parse_degree Degree
degree
parse_degree :: Pitch.Degree -> Either Text (PitchClass, Accidental)
parse_degree :: Degree -> Either Text (PitchClass, Accidental)
parse_degree (Pitch.Degree Int
pc Int
acc) = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text PitchClass
p_pc forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Either Text Accidental
p_acc
where
p_pc :: Either Text PitchClass
p_pc = case Int
pc of
Int
0 -> forall a b. b -> Either a b
Right PitchClass
C; Int
1 -> forall a b. b -> Either a b
Right PitchClass
D; Int
2 -> forall a b. b -> Either a b
Right PitchClass
E; Int
3 -> forall a b. b -> Either a b
Right PitchClass
F
Int
4 -> forall a b. b -> Either a b
Right PitchClass
G; Int
5 -> forall a b. b -> Either a b
Right PitchClass
A; Int
6 -> forall a b. b -> Either a b
Right PitchClass
B
Int
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"pitch class out of range 0-6: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
pc
p_acc :: Either Text Accidental
p_acc = case Int
acc of
-2 -> forall a b. b -> Either a b
Right Accidental
FlatFlat
-1 -> forall a b. b -> Either a b
Right Accidental
Flat
Int
0 -> forall a b. b -> Either a b
Right Accidental
Natural
Int
1 -> forall a b. b -> Either a b
Right Accidental
Sharp
Int
2 -> forall a b. b -> Either a b
Right Accidental
SharpSharp
Int
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"too many accidentals: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
acc
to_pitch :: Pitch -> Pitch.Pitch
to_pitch :: Pitch -> Pitch
to_pitch (Pitch Int
octave PitchClass
pc Accidental
acc) =
Int -> Degree -> Pitch
Pitch.Pitch Int
octave (Int -> Int -> Degree
Pitch.Degree (forall a. Enum a => a -> Int
fromEnum PitchClass
pc) Int
sharps)
where
sharps :: Int
sharps = case Accidental
acc of
Accidental
FlatFlat -> -Int
2
Accidental
Flat -> -Int
1
Accidental
Natural -> Int
0
Accidental
Sharp -> Int
1
Accidental
SharpSharp -> Int
2