-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

-- | Basic types used by both "Perform.Lilypond.Lilypond" and module that use
-- it.  Defined here to avoid circular imports.
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


-- | Convert a value to its lilypond representation.
class ToLily a where
    to_lily :: a -> Text

instance ToLily Text where
    -- Lilypond's string literal is undocumented, but this seems to work.
    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
"\""

-- | Configure how the lilypond score is generated.
data Config = Config {
    -- | Amount of RealTime per quarter note.  This is the same value used by
    -- 'Perform.Lilypond.Convert'.
    Config -> RealTime
config_quarter_duration :: !RealTime
    -- | Round everything to this duration.
    , Config -> Duration
config_quantize :: !Duration
    -- | Allow dotted rests?
    , Config -> Bool
config_dotted_rests :: !Bool
    -- | Map each instrument to its long name and short name.  The order is
    -- the order they should appear in the score.
    , 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 {
    -- | Set Staff.instrumentName or PianoStaff.instrumentName.
    -- If an instrument doesn't have a StaffConfig, the long name defaults to
    -- the instrument name.
    StaffConfig -> Text
staff_long :: !Instrument
    -- | Set Staff.shortInstrumentName or PianoStaff.shortInstrumentName.
    , StaffConfig -> Text
staff_short :: !Instrument
    -- | Additional code to include verbatim, after the \\new Staff line.
    , StaffConfig -> [Text]
staff_code :: ![Text]
    -- | If false, this staff is omitted from the score.
    , StaffConfig -> Bool
staff_display :: !Bool
    -- | If true, add an additional staff named \"down\".  The new staff has
    -- a bass clef and all of the notes replaced with hidden rests, but the
    -- key and meter changes remain.  It is configured so it will be removed
    -- from the score for systems during which it has no notes.
    --
    -- The idea is that you then use xstaff to put notes on this staff.  This
    -- is for instruments like 揚琴 that have a wide range, but aren't divided
    -- into two hands, like the piano.
    , 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 }

-- | This is emitted for every staff, regardless of its 'staff_code'.
global_staff_code :: [Text]
global_staff_code :: [Text]
global_staff_code =
    [ Text
"\\numericTimeSignature" -- Use 4/4 and 2/4 instead of C
    , Text
"\\set Staff.printKeyCancellation = ##f"
    -- Show bar numbers at (end, middle, beginning), i.e. every bar.  I prefer
    -- this to spending rehearsal time counting measures.
    -- This only needs to go on the top staff, but it doesn't hurt to put it on
    -- all of them.
    , Text
"\\override Score.BarNumber.break-visibility = ##(#f #t #t)"
    ]

-- * Duration

-- | This time duration measured as the fraction of a whole note.
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
    -- or: (2^) . (fromEnum (maxBound :: Duration) -) . fromEnum

-- | Get the longest dur that will fit within the Time, so this rounds down.
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

-- * NoteDuration

-- | A Duration plus a possible dot.
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

-- | Get the longest NoteDuration that will fit in the Time.  0 becomes D128
-- since there's no 0 duration.  This puts a bottom bound on the duration of
-- a note, which is good since 0 duration notes aren't notateable, but can
-- happen after quantization.
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
    -- I have no 0 duration, so pick the smallest available duration.
    [] -> 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

-- | Only Just if the Time fits into a single NoteDuration.
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

-- * Time

-- | Time in score units.  The maximum resolution is a 128th note, so one unit
-- is 128th of a whole note.
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)

-- * Event

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
    -- | True if this event is the tied continuation of a previous note.  In
    -- other words, if it was generated by the tie-splitting code.  This is
    -- a hack so 'Constants.v_append_first' and 'Constants.v_append_last' can
    -- differentiate.
    , 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 out non-ly environ keys so error messages are less cluttered.
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

-- * pitch

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