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
  
  -- | Utilities for equal-tempered chromatic scales with keys and modes.
  module Derive.Scale.ChromaticScales (
      ScaleMap(..)
      , SemisToNoteNumber
      , twelve_doc
      , scale_map
      , Keys
      , make_keys
      , make_scale
      , transpose
      , pitch_note
      , pitch_nn
      , input_to_note
      , group_tonic_mode
      , relative_fmt
  
      -- * util
      , show_pitch, read_pitch
      , read_key
  ) where
  import qualified Data.Either as Either
  import qualified Data.List as List
  import qualified Data.Map as Map
  import qualified Data.Text as Text
  
  import qualified Util.Doc as Doc
  import qualified Util.Lists as Lists
  import qualified Derive.Call.ScaleDegree as ScaleDegree
  import qualified Derive.Controls as Controls
  import qualified Derive.Derive as Derive
  import qualified Derive.DeriveT as DeriveT
  import qualified Derive.Env as Env
  import qualified Derive.PSignal as PSignal
  import qualified Derive.Scale as Scale
  import qualified Derive.Scale.Scales as Scales
  import qualified Derive.Scale.Theory as Theory
  import qualified Derive.Scale.TheoryFormat as TheoryFormat
  import qualified Derive.ScoreT as ScoreT
  import qualified Derive.ShowVal as ShowVal
  
  import qualified Perform.Pitch as Pitch
  
  import           Global
  
  
  -- | This contains all that is needed to define a modal key system.  It fills
  -- a similar role to 'Scales.DegreeMap' for non-keyed scales.
  data ScaleMap = ScaleMap {
      smap_fmt :: !TheoryFormat.Format
      , smap_keys :: !Keys
      , smap_default_key :: !Theory.Key
      , smap_layout :: !Theory.Layout
      -- | Configure how the scale converts 'Pitch.Semi's to frequency.
      , smap_semis_to_nn :: SemisToNoteNumber
      -- | Inclusive (bottom, top) of scale.
      , smap_range :: !(Pitch.Semi, Pitch.Semi)
      }
  
  type SemisToNoteNumber = PSignal.PitchConfig -> Pitch.FSemi
      -> Either DeriveT.PitchError Pitch.NoteNumber
  
  twelve_doc :: Doc.Doc
  twelve_doc = "Scales in the \"twelve\" family use European style note naming.\
      \ That is, note names look like octave-letter-accidentals like \"4c#\".\
      \ They have a notion of a \"layout\", which is a pattern of half and\
      \ whole steps, e.g. the piano layout, and a key, which is a subset of\
      \ notes from the scale along with a preferred spelling for them. The\
      \ rules of how enharmonic spelling works are complicated, and documented\
      \ in 'Derive.Scale.Theory'. The key is read from the `key` env var, and\
      \ each scale has a list of keys it will accept."
  
  scale_map :: Theory.Layout -> TheoryFormat.Format -> Keys -> Theory.Key
      -> ScaleMap
  scale_map layout fmt keys default_key = ScaleMap
      { smap_fmt = fmt
      , smap_keys = keys
      , smap_default_key = default_key
      , smap_layout = layout
      , smap_semis_to_nn = \_config -> return . Theory.fsemis_to_nn
      , smap_range = range
      }
      where range = (Theory.nn_to_semis 0, Theory.nn_to_semis 127)
  
  type Keys = Map Pitch.Key Theory.Key
  
  make_keys :: TheoryFormat.Format -> [Theory.Key] -> Keys
  make_keys fmt keys =
      Map.fromList $ zip (map (TheoryFormat.show_key fmt) keys) keys
  
  make_scale :: Pitch.ScaleId -> ScaleMap -> Doc.Doc -> Scale.Scale
  make_scale scale_id smap doc = Scale.Scale
      { scale_id = scale_id
      , scale_pattern = TheoryFormat.fmt_pattern (smap_fmt smap)
      , scale_symbols = []
      , scale_transposers = Scales.standard_transposers
      , scale_read = read_pitch smap . Scales.environ_key
      , scale_show = show_pitch smap . Scales.environ_key
      , scale_bottom = Theory.semis_to_pitch_sharps (smap_layout smap)
          (fst (smap_range smap))
      , scale_layout = Theory.layout_intervals (smap_layout smap)
      , scale_transpose = transpose smap
      , scale_enharmonics = enharmonics smap
      , scale_note_to_call = note_to_call scale smap
      , scale_input_to_note = input_to_note smap
      , scale_input_to_nn = Scales.computed_input_to_nn
          (input_to_note smap) (note_to_call scale smap)
      , scale_call_doc = call_doc Scales.standard_transposers smap doc
      }
      where scale = PSignal.Scale scale_id Scales.standard_transposers
  
  -- * functions
  
  transpose :: ScaleMap -> Derive.Transpose
  transpose smap transposition env steps pitch = do
      key <- read_environ_key smap env
      return $ trans key steps pitch
      where
      trans = case transposition of
          Scale.Chromatic -> Theory.transpose_chromatic
          Scale.Diatonic -> Theory.transpose_diatonic
  
  enharmonics :: ScaleMap -> Derive.Enharmonics
  enharmonics smap env note = do
      pitch <- read_pitch smap (Scales.environ_key env) note
      key <- read_environ_key smap env
      return $ Either.rights $ map (show_pitch smap (Scales.environ_key env)) $
          Theory.enharmonics_of (Theory.key_layout key) pitch
  
  note_to_call :: PSignal.Scale -> ScaleMap -> Pitch.Note -> Maybe Derive.ValCall
  note_to_call scale smap note =
      case TheoryFormat.read_relative_pitch (smap_fmt smap) note of
          Left _ -> Nothing
          Right relative -> Just $ ScaleDegree.scale_degree scale
              (pitch_nn smap relative) (pitch_note smap relative)
  
  -- | Create a PitchNote for 'ScaleDegree.scale_degree'.
  pitch_note :: ScaleMap -> TheoryFormat.RelativePitch -> Scale.PitchNote
  pitch_note smap relative (PSignal.PitchConfig env controls) = do
      -- Adjustment to absolute is only necessary for 'pitch_nn', since
      -- NoteNumbers are absolute.
      -- TODO I should leave as relative to preserve naturals, otherwise twelve-k
      -- doesn't preserve it through a pitch->note.
      let pitch = TheoryFormat.relative_to_absolute relative
      let maybe_key = Scales.environ_key env
      let c = round chromatic
          o = round octave
          d = round diatonic
      -- Symbolic pitch is still relative, so while I transpose with the key,
      -- I don't give it to 'show_pitch'.
      show_pitch smap Nothing =<< if o == 0 && d == 0 && c == 0
          then return pitch
          else do
              key <- read_key smap maybe_key
              return $ Pitch.add_octave o $ Theory.transpose_chromatic key c $
                  Theory.transpose_diatonic key d pitch
      where
      octave = get Controls.octave
      chromatic = get Controls.chromatic
      diatonic = get Controls.diatonic
      get m = Map.findWithDefault 0 m controls
  
  -- | Create a PitchNn for 'ScaleDegree.scale_degree'.
  pitch_nn :: ScaleMap -> TheoryFormat.RelativePitch -> Scale.PitchNn
  pitch_nn smap relative config@(PSignal.PitchConfig env controls) = do
      let maybe_key = Scales.environ_key env
      pitch <- TheoryFormat.fmt_to_absolute (smap_fmt smap) maybe_key relative
      dsteps <- if diatonic == 0 then Right 0 else do
          key <- read_key smap maybe_key
          return $ Theory.diatonic_to_chromatic key
              (Pitch.pitch_degree pitch) diatonic
      let semis = Theory.pitch_to_semis (smap_layout smap) pitch
          degree = octave * fromIntegral per_octave
              + fromIntegral semis + chromatic + dsteps
      smap_semis_to_nn smap config degree
      where
      octave = get Controls.octave
      chromatic = get Controls.chromatic
      diatonic = get Controls.diatonic
      get m = Map.findWithDefault 0 m controls
      per_octave = Theory.layout_semis_per_octave (smap_layout smap)
  
  input_to_note :: ScaleMap -> Scales.InputToNote
  input_to_note smap env (Pitch.Input kbd_type pitch frac) = do
      pitch <- Scales.kbd_to_scale kbd_type pc_per_octave (key_tonic key) pitch
      let intervals = if is_relative
              then Theory.key_intervals key
              else Theory.layout_intervals (smap_layout smap)
      unless (Theory.contains_degree intervals (Pitch.pitch_degree pitch)
              && in_range smap pitch) $
          Left DeriveT.InvalidInput
      -- Relative scales don't need to figure out enharmonic spelling, and
      -- besides it would be wrong since it assumes Pitch 0 0 is C.
      let pick_enharmonic = if is_relative then id else Theory.pick_enharmonic key
      -- Don't pass the key, because I want the Input to also be relative, i.e.
      -- Pitch 0 0 should be scale degree 0 no matter the key.
      note <- invalid_input $ show_pitch smap
          (if is_relative then Nothing else (Scales.environ_key env))
          (pick_enharmonic pitch)
      return $ ScaleDegree.pitch_expr frac note
      where
      is_relative = TheoryFormat.fmt_relative (smap_fmt smap)
      invalid_input (Left (DeriveT.OutOfRangeError {})) =
          Left DeriveT.InvalidInput
      invalid_input x = x
      pc_per_octave = Theory.layout_pc_per_octave (smap_layout smap)
      -- Default to a key because otherwise you couldn't enter notes in an
      -- empty score!
      key = fromMaybe (smap_default_key smap) $
          flip Map.lookup (smap_keys smap) =<< Scales.environ_key env
  
  in_range :: ScaleMap -> Pitch.Pitch -> Bool
  in_range smap pitch = bottom <= semis && semis <= top
      where
      (bottom, top) = smap_range smap
      semis = Theory.pitch_to_semis (smap_layout smap) pitch
  
  call_doc :: Set ScoreT.Control -> ScaleMap -> Doc.Doc -> Derive.DocumentedCall
  call_doc transposers smap doc =
      Scales.annotate_call_doc transposers doc fields call_doc
      where
      call_doc = Scales.scale_degree_doc ScaleDegree.scale_degree
      -- Not efficient, but shouldn't matter for docs.
      default_key = fst <$> List.find ((== smap_default_key smap) . snd)
          (Map.toList (smap_keys smap))
      (bottom, top) = smap_range smap
      show_p = either Doc.pretty Doc.pretty . show_pitch smap Nothing
          . Theory.semis_to_pitch_sharps (smap_layout smap)
      fields = concat
          [ [("range", show_p bottom <> " to " <> show_p top)]
          , maybe [] (\n -> [("default key", ShowVal.doc n)]) default_key
          , [ ("keys", format_keys $ Map.keys (smap_keys smap)) ]
          ]
  
  format_keys :: [Pitch.Key] -> Doc.Doc
  format_keys keys
      | all (("-" `Text.isInfixOf`) . Pitch.key_text) keys = Doc.commas $
          map (Doc.literal . fst) $ group_tonic_mode $ map (, ()) keys
      | otherwise = Doc.commas (map Doc.pretty keys)
  
  -- | Assuming keys are formatted @tonic-mode@, group keys by mode and replace
  -- the tonics with a pattern.
  group_tonic_mode :: [(Pitch.Key, a)] -> [(Text, a)]
  group_tonic_mode = map extract . Lists.keyedGroupSort key . map (first split)
      where
      extract (mode, group) = (fmt mode (map (fst . fst) group), snd (head group))
      key ((_, mode), _) = mode
      split (Pitch.Key t) = (pre, Text.drop 1 post)
          where (pre, post) = Text.break (=='-') t
      fmt mode keys = "(" <> Text.intercalate "|" keys <> ")-" <> mode
  
  -- * format
  
  relative_fmt :: Theory.Key -> Keys -> TheoryFormat.RelativeFormat Theory.Key
  relative_fmt default_key all_keys  = TheoryFormat.RelativeFormat
      { rel_config = TheoryFormat.default_config
      , rel_key_config = TheoryFormat.KeyConfig
          { key_parse = Scales.get_key default_key all_keys
          , key_default = default_key
          }
      , rel_show_degree = TheoryFormat.show_degree_chromatic
      , rel_to_absolute = TheoryFormat.chromatic_to_absolute
      }
  
  -- * util
  
  key_tonic :: Theory.Key -> Pitch.PitchClass
  key_tonic = Pitch.degree_pc . Theory.key_tonic
  
  show_pitch :: ScaleMap -> Maybe Pitch.Key -> Pitch.Pitch
      -> Either DeriveT.PitchError Pitch.Note
  show_pitch smap key = Right . TheoryFormat.show_pitch (smap_fmt smap) key
      -- Previously this would check for OutOfRange, but it meant I couldn't
      -- transpose a pitch to out of range even if I was going to later transpose
      -- it back in range (say via octave wrapping).  Since the range is
      -- ultimately which degrees can be mapped to frequencies, it seems it
      -- doesn't hurt anything for the symbolic pitch to be theoretically
      -- boundless.
  
  read_pitch :: ScaleMap -> Maybe Pitch.Key -> Pitch.Note
      -> Either DeriveT.PitchError Pitch.Pitch
  read_pitch smap = TheoryFormat.read_pitch (smap_fmt smap)
  
  read_environ_key :: ScaleMap -> Env.Environ
      -> Either DeriveT.PitchError Theory.Key
  read_environ_key smap = Scales.get_key (smap_default_key smap) (smap_keys smap)
      . Scales.environ_key
  
  read_key :: ScaleMap -> Maybe Pitch.Key
      -> Either DeriveT.PitchError Theory.Key
  read_key smap = Scales.get_key (smap_default_key smap) (smap_keys smap)
  