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
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text -> Text
Text.replace Text
"\"" Text
"\\\"" Text
txt Text -> Text -> Text
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
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
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]
(Int -> ReadS Config)
-> ReadS [Config]
-> ReadPrec Config
-> ReadPrec [Config]
-> Read 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
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
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 = (Config -> RealTime)
-> ((RealTime -> RealTime) -> Config -> Config)
-> Config :-> RealTime
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 = (Config -> Duration)
-> ((Duration -> Duration) -> Config -> Config)
-> Config :-> Duration
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 = (Config -> Bool)
-> ((Bool -> Bool) -> Config -> Config) -> Config :-> Bool
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 = (Config -> [(Instrument, StaffConfig)])
-> (([(Instrument, StaffConfig)] -> [(Instrument, StaffConfig)])
-> Config -> Config)
-> Config :-> [(Instrument, StaffConfig)]
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
(StaffConfig -> StaffConfig -> Bool)
-> (StaffConfig -> StaffConfig -> Bool) -> Eq StaffConfig
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]
(Int -> ReadS StaffConfig)
-> ReadS [StaffConfig]
-> ReadPrec StaffConfig
-> ReadPrec [StaffConfig]
-> Read 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
(Int -> StaffConfig -> ShowS)
-> (StaffConfig -> String)
-> ([StaffConfig] -> ShowS)
-> Show StaffConfig
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 = (StaffConfig -> Text)
-> ((Text -> Text) -> StaffConfig -> StaffConfig)
-> StaffConfig :-> Text
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 = (StaffConfig -> Text)
-> ((Text -> Text) -> StaffConfig -> StaffConfig)
-> StaffConfig :-> Text
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 = (StaffConfig -> [Text])
-> (([Text] -> [Text]) -> StaffConfig -> StaffConfig)
-> StaffConfig :-> [Text]
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 = (StaffConfig -> Bool)
-> ((Bool -> Bool) -> StaffConfig -> StaffConfig)
-> StaffConfig :-> Bool
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 = (StaffConfig -> Bool)
-> ((Bool -> Bool) -> StaffConfig -> StaffConfig)
-> StaffConfig :-> Bool
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", RealTime -> Doc
forall a. Pretty a => a -> Doc
Pretty.format RealTime
quarter)
, (Text
"quantize", Duration -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Duration
quantize)
, (Text
"dotted_rests", Bool -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Bool
dotted)
, (Text
"staves", [(Instrument, StaffConfig)] -> Doc
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", Text -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Text
long)
, (Text
"short", Text -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Text
short)
, (Text
"code", [Text] -> Doc
forall a. Pretty a => a -> Doc
Pretty.format [Text]
code)
, (Text
"display", Bool -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Bool
display)
, (Text
"add_bass_staff", Bool -> Doc
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]
(Duration -> Duration)
-> (Duration -> Duration)
-> (Int -> Duration)
-> (Duration -> Int)
-> (Duration -> [Duration])
-> (Duration -> Duration -> [Duration])
-> (Duration -> Duration -> [Duration])
-> (Duration -> Duration -> Duration -> [Duration])
-> Enum 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
Duration -> Duration -> Bounded Duration
forall a. a -> a -> Bounded a
maxBound :: Duration
$cmaxBound :: Duration
minBound :: Duration
$cminBound :: Duration
Bounded, Duration -> Duration -> Bool
(Duration -> Duration -> Bool)
-> (Duration -> Duration -> Bool) -> Eq Duration
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
Eq Duration
-> (Duration -> Duration -> Ordering)
-> (Duration -> Duration -> Bool)
-> (Duration -> Duration -> Bool)
-> (Duration -> Duration -> Bool)
-> (Duration -> Duration -> Bool)
-> (Duration -> Duration -> Duration)
-> (Duration -> Duration -> Duration)
-> Ord 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]
(Int -> ReadS Duration)
-> ReadS [Duration]
-> ReadPrec Duration
-> ReadPrec [Duration]
-> Read 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
(Int -> Duration -> ShowS)
-> (Duration -> String) -> ([Duration] -> ShowS) -> Show Duration
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 = Duration -> Text
forall a. Show a => a -> Text
showt
instance ToLily Duration where to_lily :: Duration -> Text
to_lily = String -> Text
txt (String -> Text) -> (Duration -> String) -> Duration -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 ShowS -> (Duration -> String) -> Duration -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Duration -> String
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 -> Duration -> Maybe Duration
forall a. a -> Maybe a
Just Duration
D1; Int
2 -> Duration -> Maybe Duration
forall a. a -> Maybe a
Just Duration
D2; Int
4 -> Duration -> Maybe Duration
forall a. a -> Maybe a
Just Duration
D4; Int
8 -> Duration -> Maybe Duration
forall a. a -> Maybe a
Just Duration
D8
Int
16 -> Duration -> Maybe Duration
forall a. a -> Maybe a
Just Duration
D16; Int
32 -> Duration -> Maybe Duration
forall a. a -> Maybe a
Just Duration
D32; Int
64 -> Duration -> Maybe Duration
forall a. a -> Maybe a
Just Duration
D64; Int
128 -> Duration -> Maybe Duration
forall a. a -> Maybe a
Just Duration
D128
Int
_ -> Maybe Duration
forall a. Maybe a
Nothing
dur_to_time :: Duration -> Time
dur_to_time :: Duration -> Time
dur_to_time Duration
dur = Int -> Time
Time (Int -> Time) -> Int -> 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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 = Duration
D128
| Int
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4 = Duration
D64
| Int
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8 = Duration
D32
| Int
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
16 = Duration
D16
| Int
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
32 = Duration
D8
| Int
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
64 = Duration
D4
| Int
t Int -> Int -> Bool
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 Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Duration -> Time
dur_to_time Duration
dur = Duration
dur Duration -> [Duration] -> [Duration]
forall a. a -> [a] -> [a]
: Duration -> Time -> [Duration]
go Duration
dur (Time
time Time -> Time -> Time
forall a. Num a => a -> a -> a
- Duration -> Time
dur_to_time Duration
dur)
| Duration
dur Duration -> Duration -> Bool
forall a. Eq a => a -> a -> Bool
== Duration
D128 = []
| Bool
otherwise = Duration -> Time -> [Duration]
go (Duration -> Duration
forall a. Enum a => a -> a
succ Duration
dur) Time
time
data NoteDuration = NoteDuration !Duration !Bool
deriving (NoteDuration -> NoteDuration -> Bool
(NoteDuration -> NoteDuration -> Bool)
-> (NoteDuration -> NoteDuration -> Bool) -> Eq NoteDuration
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
(Int -> NoteDuration -> ShowS)
-> (NoteDuration -> String)
-> ([NoteDuration] -> ShowS)
-> Show NoteDuration
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) = Duration -> Text
forall a. ToLily a => a -> Text
to_lily Duration
dur Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if Bool
dot then Text
"." else Text
""
instance Pretty NoteDuration where pretty :: NoteDuration -> Text
pretty = (Text
"D"<>) (Text -> Text) -> (NoteDuration -> Text) -> NoteDuration -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteDuration -> Text
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) Text -> Text -> Text
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 Time -> Time -> Time
forall a. Num a => a -> a -> a
+ if Bool
dotted Bool -> Bool -> Bool
&& Duration
dur Duration -> Duration -> Bool
forall a. Eq a => a -> a -> Bool
/= Duration
D128 then Duration -> Time
dur_to_time (Duration -> Duration
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 Duration -> Duration -> Bool
forall a. Eq a => a -> a -> Bool
== Duration -> Duration
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] -> NoteDuration -> Maybe NoteDuration
forall a. a -> Maybe a
Just NoteDuration
d
[NoteDuration]
_ -> Maybe 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 Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
0 = NoteDuration
dur NoteDuration -> [NoteDuration] -> [NoteDuration]
forall a. a -> [a] -> [a]
: Time -> [NoteDuration]
time_to_note_durs (Time
t Time -> Time -> Time
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
(Time -> Time -> Bool) -> (Time -> Time -> Bool) -> Eq Time
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
Eq Time
-> (Time -> Time -> Ordering)
-> (Time -> Time -> Bool)
-> (Time -> Time -> Bool)
-> (Time -> Time -> Bool)
-> (Time -> Time -> Bool)
-> (Time -> Time -> Time)
-> (Time -> Time -> Time)
-> Ord 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
(Int -> Time -> ShowS)
-> (Time -> String) -> ([Time] -> ShowS) -> Show Time
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
(Time -> Time -> Time)
-> (Time -> Time -> Time)
-> (Time -> Time -> Time)
-> (Time -> Time)
-> (Time -> Time)
-> (Time -> Time)
-> (Integer -> Time)
-> Num 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]
(Time -> Time)
-> (Time -> Time)
-> (Int -> Time)
-> (Time -> Int)
-> (Time -> [Time])
-> (Time -> Time -> [Time])
-> (Time -> Time -> [Time])
-> (Time -> Time -> Time -> [Time])
-> Enum 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
Num Time -> Ord Time -> (Time -> Rational) -> Real Time
Time -> Rational
forall a. Num a -> Ord a -> (a -> Rational) -> Real a
toRational :: Time -> Rational
$ctoRational :: Time -> Rational
Real, Enum Time
Real Time
Real Time
-> Enum Time
-> (Time -> Time -> Time)
-> (Time -> Time -> Time)
-> (Time -> Time -> Time)
-> (Time -> Time -> Time)
-> (Time -> Time -> (Time, Time))
-> (Time -> Time -> (Time, Time))
-> (Time -> Integer)
-> Integral 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 = Rational -> Text
forall a. Pretty a => a -> Text
pretty (Rational -> Text) -> (Time -> Rational) -> Time -> Text
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 = Time -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Time
t Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Time -> Rational
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 (Int -> Time) -> (RealTime -> Int) -> RealTime -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Int) -> (RealTime -> Double) -> RealTime -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double
adjust (Double -> Double) -> (RealTime -> Double) -> RealTime -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> Double
RealTime.to_seconds
where
adjust :: Double -> Double
adjust Double
n = Double
n Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ RealTime -> Double
RealTime.to_seconds RealTime
quarter Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
qtime)
qtime :: Double
qtime = Time -> Double
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 Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
0 = Time -> Maybe Time
forall a. a -> Maybe a
Just (Int -> Time
Time Int
i)
| Bool
otherwise = Maybe Time
forall a. Maybe a
Nothing
where (Int
i, Rational
frac) = Rational -> (Int, Rational)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction (Time -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Time
t Rational -> Rational -> Rational
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 Int -> Int -> Int
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
(Int -> Event -> ShowS)
-> (Event -> String) -> ([Event] -> ShowS) -> Show Event
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 Time -> Time -> Time
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Event -> Time
event_end Event
e1 Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Event -> Time
event_start Event
e2 Bool -> Bool -> Bool
|| Event -> Time
event_start Event
e1 Time -> Time -> Bool
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 (Environ -> Attributes)
-> (Event -> Environ) -> Event -> 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" ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
[ Time -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Time
start, Time -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Time
dur
, Doc -> (Pitch -> Doc) -> Maybe Pitch -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
"rest" (Text -> Doc
Pretty.text (Text -> Doc) -> (Pitch -> Text) -> Pitch -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> Text
forall a. ToLily a => a -> Text
to_lily) Maybe Pitch
pitch, Instrument -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Instrument
inst
] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ if Map Text Val -> Bool
forall k a. Map k a -> Bool
Map.null Map Text Val
e then [] else [Environ -> Doc
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 (Map Text Val -> Environ) -> Map Text Val -> Environ
forall a b. (a -> b) -> a -> b
$ (Text -> Val -> Bool) -> Map Text Val -> Map Text Val
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 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
EnvKey.attributes Bool -> Bool -> Bool
&& Val -> Bool
has_attrs Val
val)
Bool -> Bool -> Bool
|| Text
key Text -> [Text] -> Bool
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 Attributes -> Attributes -> Bool
forall a. Eq a => a -> a -> Bool
/= Attributes
forall a. Monoid a => a
mempty
has_attrs Val
_ = Bool
True
data Pitch = Pitch !Int !PitchClass !Accidental
deriving (Pitch -> Pitch -> Bool
(Pitch -> Pitch -> Bool) -> (Pitch -> Pitch -> Bool) -> Eq Pitch
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
(Int -> Pitch -> ShowS)
-> (Pitch -> String) -> ([Pitch] -> ShowS) -> Show Pitch
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
Eq Pitch
-> (Pitch -> Pitch -> Ordering)
-> (Pitch -> Pitch -> Bool)
-> (Pitch -> Pitch -> Bool)
-> (Pitch -> Pitch -> Bool)
-> (Pitch -> Pitch -> Bool)
-> (Pitch -> Pitch -> Pitch)
-> (Pitch -> Pitch -> Pitch)
-> Ord 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
(PitchClass -> PitchClass -> Bool)
-> (PitchClass -> PitchClass -> Bool) -> Eq PitchClass
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
(Int -> PitchClass -> ShowS)
-> (PitchClass -> String)
-> ([PitchClass] -> ShowS)
-> Show PitchClass
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
Eq PitchClass
-> (PitchClass -> PitchClass -> Ordering)
-> (PitchClass -> PitchClass -> Bool)
-> (PitchClass -> PitchClass -> Bool)
-> (PitchClass -> PitchClass -> Bool)
-> (PitchClass -> PitchClass -> Bool)
-> (PitchClass -> PitchClass -> PitchClass)
-> (PitchClass -> PitchClass -> PitchClass)
-> Ord 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]
(PitchClass -> PitchClass)
-> (PitchClass -> PitchClass)
-> (Int -> PitchClass)
-> (PitchClass -> Int)
-> (PitchClass -> [PitchClass])
-> (PitchClass -> PitchClass -> [PitchClass])
-> (PitchClass -> PitchClass -> [PitchClass])
-> (PitchClass -> PitchClass -> PitchClass -> [PitchClass])
-> Enum 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
(Accidental -> Accidental -> Bool)
-> (Accidental -> Accidental -> Bool) -> Eq Accidental
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
(Int -> Accidental -> ShowS)
-> (Accidental -> String)
-> ([Accidental] -> ShowS)
-> Show Accidental
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
Eq Accidental
-> (Accidental -> Accidental -> Ordering)
-> (Accidental -> Accidental -> Bool)
-> (Accidental -> Accidental -> Bool)
-> (Accidental -> Accidental -> Bool)
-> (Accidental -> Accidental -> Bool)
-> (Accidental -> Accidental -> Accidental)
-> (Accidental -> Accidental -> Accidental)
-> Ord 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 = Pitch -> Text
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) = PitchClass -> Text
forall a. ToLily a => a -> Text
to_lily PitchClass
pc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Accidental -> Text
forall a. ToLily a => a -> Text
to_lily Accidental
acc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
oct_mark
where
oct_mark :: Text
oct_mark
| Int
oct Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 = Int -> Text -> Text
Text.replicate Int
oct Text
"'"
| Bool
otherwise = Int -> Text -> Text
Text.replicate (Int -> Int
forall a. Num a => a -> a
abs Int
oct) Text
","
where oct :: Int
oct = Int
octave Int -> Int -> Int
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) =
(PitchClass -> Accidental -> Pitch)
-> (PitchClass, Accidental) -> Pitch
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Int -> PitchClass -> Accidental -> Pitch
Pitch Int
octave) ((PitchClass, Accidental) -> Pitch)
-> Either Text (PitchClass, Accidental) -> Either Text Pitch
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) = (,) (PitchClass -> Accidental -> (PitchClass, Accidental))
-> Either Text PitchClass
-> Either Text (Accidental -> (PitchClass, Accidental))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text PitchClass
p_pc Either Text (Accidental -> (PitchClass, Accidental))
-> Either Text Accidental -> Either Text (PitchClass, Accidental)
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 -> PitchClass -> Either Text PitchClass
forall a b. b -> Either a b
Right PitchClass
C; Int
1 -> PitchClass -> Either Text PitchClass
forall a b. b -> Either a b
Right PitchClass
D; Int
2 -> PitchClass -> Either Text PitchClass
forall a b. b -> Either a b
Right PitchClass
E; Int
3 -> PitchClass -> Either Text PitchClass
forall a b. b -> Either a b
Right PitchClass
F
Int
4 -> PitchClass -> Either Text PitchClass
forall a b. b -> Either a b
Right PitchClass
G; Int
5 -> PitchClass -> Either Text PitchClass
forall a b. b -> Either a b
Right PitchClass
A; Int
6 -> PitchClass -> Either Text PitchClass
forall a b. b -> Either a b
Right PitchClass
B
Int
_ -> Text -> Either Text PitchClass
forall a b. a -> Either a b
Left (Text -> Either Text PitchClass) -> Text -> Either Text PitchClass
forall a b. (a -> b) -> a -> b
$ Text
"pitch class out of range 0-6: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showt Int
pc
p_acc :: Either Text Accidental
p_acc = case Int
acc of
-2 -> Accidental -> Either Text Accidental
forall a b. b -> Either a b
Right Accidental
FlatFlat
-1 -> Accidental -> Either Text Accidental
forall a b. b -> Either a b
Right Accidental
Flat
Int
0 -> Accidental -> Either Text Accidental
forall a b. b -> Either a b
Right Accidental
Natural
Int
1 -> Accidental -> Either Text Accidental
forall a b. b -> Either a b
Right Accidental
Sharp
Int
2 -> Accidental -> Either Text Accidental
forall a b. b -> Either a b
Right Accidental
SharpSharp
Int
_ -> Text -> Either Text Accidental
forall a b. a -> Either a b
Left (Text -> Either Text Accidental) -> Text -> Either Text Accidental
forall a b. (a -> b) -> a -> b
$ Text
"too many accidentals: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
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 (PitchClass -> Int
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