content: -- 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 txt = "\"" <> Text.replace "\"" "\\\"" txt <> "\""
  
  -- | 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_quarter_duration :: !RealTime
      -- | Round everything to this duration.
      , config_quantize :: !Duration
      -- | Allow dotted rests?
      , 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_staves :: ![(ScoreT.Instrument, StaffConfig)]
      } deriving (Eq, Read, Show)
  
  quarter_duration = Lens.lens config_quarter_duration
      (\f r -> r { config_quarter_duration = f (config_quarter_duration r) })
  quantize = Lens.lens config_quantize
      (\f r -> r { config_quantize = f (config_quantize r) })
  dotted_rests = Lens.lens config_dotted_rests
      (\f r -> r { config_dotted_rests = f (config_dotted_rests r) })
  staves = Lens.lens config_staves
      (\f r -> r { config_staves = f (config_staves 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.
      staff_long :: !Instrument
      -- | Set Staff.shortInstrumentName or PianoStaff.shortInstrumentName.
      , staff_short :: !Instrument
      -- | Additional code to include verbatim, after the \\new Staff line.
      , staff_code :: ![Text]
      -- | If false, this staff is omitted from the score.
      , 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.
      , staff_add_bass_staff :: !Bool
      } deriving (Eq, Read, Show)
  
  long = Lens.lens staff_long (\f r -> r { staff_long = f (staff_long r) })
  short = Lens.lens staff_short (\f r -> r { staff_short = f (staff_short r) })
  code = Lens.lens staff_code (\f r -> r { staff_code = f (staff_code r) })
  display = Lens.lens staff_display
      (\f r -> r { staff_display = f (staff_display r) })
  add_bass_staff = Lens.lens staff_add_bass_staff
      (\f r -> r { staff_add_bass_staff = f (staff_add_bass_staff r) })
  
  type Instrument = Text
  
  instance Pretty Config where
      format (Config quarter quantize dotted staves) = Pretty.record "Config"
          [ ("quarter_duration", Pretty.format quarter)
          , ("quantize", Pretty.format quantize)
          , ("dotted_rests", Pretty.format dotted)
          , ("staves", Pretty.format staves)
          ]
  
  instance Pretty StaffConfig where
      format (StaffConfig long short code display add_bass) =
          Pretty.record "StaffConfig"
              [ ("long", Pretty.format long)
              , ("short", Pretty.format short)
              , ("code", Pretty.format code)
              , ("display", Pretty.format display)
              , ("add_bass_staff", Pretty.format add_bass)
              ]
  
  default_config :: Config
  default_config = Config
      { config_quarter_duration = 1
      , config_quantize = D32
      , config_dotted_rests = False
      , config_staves = []
      }
  
  empty_staff_config :: StaffConfig
  empty_staff_config = StaffConfig
      { staff_long = ""
      , staff_short = ""
      , staff_code = []
      , staff_display = True
      , staff_add_bass_staff = False
      }
  
  default_staff_config :: ScoreT.Instrument -> StaffConfig
  default_staff_config inst =
      empty_staff_config { staff_long = ScoreT.instrument_name inst }
  
  -- | This is emitted for every staff, regardless of its 'staff_code'.
  global_staff_code :: [Text]
  global_staff_code =
      [ "\\numericTimeSignature" -- Use 4/4 and 2/4 instead of C
      , "\\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.
      , "\\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 (Enum, Bounded, Eq, Ord, Read, Show)
  
  instance Pretty Duration where pretty = showt
  instance ToLily Duration where to_lily = txt . drop 1 . show
  
  dur_char :: Duration -> Char
  dur_char d = case d of
      D1 -> 'w'; D2 -> 'h'; D4 -> 'q'; D8 -> 'e'
      D16 -> 's'; D32 -> 't'; D64 -> 'y'; D128 -> 'z'
  
  int_dur :: Int -> Maybe Duration
  int_dur i = case i of
      1 -> Just D1; 2 -> Just D2; 4 -> Just D4; 8 -> Just D8
      16 -> Just D16; 32 -> Just D32; 64 -> Just D64; 128 -> Just D128
      _ -> Nothing
  
  dur_to_time :: Duration -> Time
  dur_to_time dur = Time $ case dur of
      D1 -> 128; D2 -> 64; D4 -> 32; D8 -> 16
      D16 -> 8; D32 -> 4; D64 -> 2; D128 -> 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 t)
      | t < 2 = D128
      | t < 4 = D64
      | t < 8 = D32
      | t < 16 = D16
      | t < 32 = D8
      | t < 64 = D4
      | t < 128 = D2
      | otherwise = D1
  
  time_to_durs :: Time -> [Duration]
  time_to_durs time = go D1 time
      where
      go dur time
          | time >= dur_to_time dur = dur : go dur (time - dur_to_time dur)
          | dur == D128 = []
          | otherwise = go (succ dur) time
  
  -- * NoteDuration
  
  -- | A Duration plus a possible dot.
  data NoteDuration = NoteDuration !Duration !Bool
      deriving (Eq, Show)
  
  instance ToLily NoteDuration where
      to_lily (NoteDuration dur dot) = to_lily dur <> if dot then "." else ""
  
  instance Pretty NoteDuration where pretty = ("D"<>) . to_lily
  
  note_dur_char :: NoteDuration -> Text
  note_dur_char (NoteDuration dur dotted) =
      Text.singleton (dur_char dur) <> if dotted then "." else ""
  
  note_dur_to_time :: NoteDuration -> Time
  note_dur_to_time (NoteDuration dur dotted) =
      dur_to_time dur + if dotted && dur /= D128 then dur_to_time (succ dur)
          else 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 t = case time_to_durs t of
      [d1, d2] | d2 == succ d1 -> NoteDuration d1 True
      d : _ -> NoteDuration d False
      -- I have no 0 duration, so pick the smallest available duration.
      [] -> NoteDuration D128 False
  
  dur_to_note_dur :: Duration -> NoteDuration
  dur_to_note_dur d = NoteDuration d False
  
  -- | Only Just if the Time fits into a single NoteDuration.
  is_note_dur :: Time -> Maybe NoteDuration
  is_note_dur t = case time_to_note_durs t of
      [d] -> Just d
      _ -> Nothing
  
  time_to_note_durs :: Time -> [NoteDuration]
  time_to_note_durs t
      | t > 0 = dur : time_to_note_durs (t - note_dur_to_time dur)
      | otherwise = []
      where dur = time_to_note_dur 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 (Eq, Ord, Show, Num, Enum, Real, Integral)
  
  instance Pretty Time where pretty = pretty . to_whole
  
  to_whole :: Time -> Rational
  to_whole t = fromIntegral t / fromIntegral time_per_whole
  
  time_per_whole :: Time
  time_per_whole = dur_to_time D1
  
  real_to_time :: RealTime -> RealTime -> Time
  real_to_time quarter = Time . floor . adjust . RealTime.to_seconds
      where
      adjust n = n * (1 / RealTime.to_seconds quarter * qtime)
      qtime = fromIntegral (dur_to_time D4)
  
  multiply :: Rational -> Time -> Maybe Time
  multiply factor t
      | frac == 0 = Just (Time i)
      | otherwise = Nothing
      where (i, frac) = properFraction (fromIntegral t * factor)
  
  multiply_int :: Int -> Time -> Time
  multiply_int factor (Time t) = Time (t * factor)
  
  -- * Event
  
  data Event = Event {
      event_start :: !Time
      , event_duration :: !Time
      , event_pitch :: !(Maybe Pitch)
      , event_instrument :: !ScoreT.Instrument
      , event_environ :: !DeriveT.Environ
      , 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_clipped :: !Bool
      } deriving (Show)
  
  event_end :: Event -> Time
  event_end event = event_start event + event_duration event
  
  event_overlaps :: Event -> Event -> Bool
  event_overlaps e1 e2 =
      not $ event_end e1 <= event_start e2 || event_start e1 >= event_end e2
  
  event_attributes :: Event -> Attrs.Attributes
  event_attributes = DeriveT.environ_attributes . event_environ
  
  instance Pretty Event where
      format (Event start dur pitch inst env_ _stack _clipped) =
          Pretty.constructor "Event" $
              [ Pretty.format start, Pretty.format dur
              , maybe "rest" (Pretty.text . to_lily) pitch, Pretty.format inst
              ] ++ if Map.null e then [] else [Pretty.format env]
          where env@(DeriveT.Environ e) = strip_environ env_
  
  -- | Strip out non-ly environ keys so error messages are less cluttered.
  strip_environ :: DeriveT.Environ -> DeriveT.Environ
  strip_environ (DeriveT.Environ env) =
      DeriveT.Environ $ Map.filterWithKey interesting env
      where
      interesting key val = "ly-" `Text.isPrefixOf` key
          || (key == EnvKey.attributes && has_attrs val)
          || key `elem` [EnvKey.voice, EnvKey.hand]
      has_attrs (DeriveT.VAttributes attrs) = attrs /= mempty
      has_attrs _ = True
  
  -- * pitch
  
  data Pitch = Pitch !Int !PitchClass !Accidental
      deriving (Eq, Show, Ord)
  data PitchClass = C | D | E | F | G | A | B
      deriving (Eq, Show, Ord, Enum)
  data Accidental = FlatFlat | Flat | Natural | Sharp | SharpSharp
      deriving (Eq, Show, Ord)
  
  instance Pretty Pitch where pretty = to_lily
  instance ToLily Pitch where
      to_lily (Pitch octave pc acc) = to_lily pc <> to_lily acc <> oct_mark
          where
          oct_mark
              | oct >= 0 = Text.replicate oct "'"
              | otherwise = Text.replicate (abs oct) ","
              where oct = octave - 3
  
  instance ToLily PitchClass where
      to_lily pc = case pc of
          C -> "c"; D -> "d"; E -> "e"; F -> "f"
          G -> "g"; A -> "a"; B -> "b"
  
  instance ToLily Accidental where
      to_lily acc = case acc of
          FlatFlat -> "ff"
          Flat -> "f"
          Natural -> ""
          Sharp -> "s"
          SharpSharp -> "ss"
  
  parse_pitch :: Pitch.Pitch -> Either Text Pitch
  parse_pitch (Pitch.Pitch octave degree) =
      uncurry (Pitch octave) <$> parse_degree degree
  
  parse_degree :: Pitch.Degree -> Either Text (PitchClass, Accidental)
  parse_degree (Pitch.Degree pc acc) = (,) <$> p_pc <*> p_acc
      where
      p_pc = case pc of
          0 -> Right C; 1 -> Right D; 2 -> Right E; 3 -> Right F
          4 -> Right G; 5 -> Right A; 6 -> Right B
          _ -> Left $ "pitch class out of range 0-6: " <> showt pc
      p_acc = case acc of
          -2 -> Right FlatFlat
          -1 -> Right Flat
          0 -> Right Natural
          1 -> Right Sharp
          2 -> Right SharpSharp
          _ -> Left $ "too many accidentals: " <> showt acc
  
  to_pitch :: Pitch -> Pitch.Pitch
  to_pitch (Pitch octave pc acc) =
      Pitch.Pitch octave (Pitch.Degree (fromEnum pc) sharps)
      where
      sharps = case acc of
          FlatFlat -> -2
          Flat -> -1
          Natural -> 0
          Sharp -> 1
          SharpSharp -> 2
  