-- 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.Debug as Debug
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 {
    ScaleMap -> Format
smap_fmt :: !TheoryFormat.Format
    , ScaleMap -> Keys
smap_keys :: !Keys
    , ScaleMap -> Key
smap_default_key :: !Theory.Key
    , ScaleMap -> Layout
smap_layout :: !Theory.Layout
    -- | Configure how the scale converts 'Pitch.Semi's to frequency.
    , ScaleMap -> SemisToNoteNumber
smap_semis_to_nn :: SemisToNoteNumber
    -- | Inclusive (bottom, top) of scale.
    , ScaleMap -> (Semi, Semi)
smap_range :: !(Pitch.Semi, Pitch.Semi)
    }

type SemisToNoteNumber = PSignal.PitchConfig -> Pitch.FSemi
    -> Either DeriveT.PitchError Pitch.NoteNumber

twelve_doc :: Doc.Doc
twelve_doc :: Doc
twelve_doc = 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 -> Format -> Keys -> Key -> ScaleMap
scale_map Layout
layout Format
fmt Keys
keys Key
default_key = ScaleMap
    { smap_fmt :: Format
smap_fmt = Format
fmt
    , smap_keys :: Keys
smap_keys = Keys
keys
    , smap_default_key :: Key
smap_default_key = Key
default_key
    , smap_layout :: Layout
smap_layout = Layout
layout
    , smap_semis_to_nn :: SemisToNoteNumber
smap_semis_to_nn = \PitchConfig
_config -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Y -> NoteNumber
Theory.fsemis_to_nn
    , smap_range :: (Semi, Semi)
smap_range = (Semi, Semi)
range
    }
    where range :: (Semi, Semi)
range = (Semi -> Semi
Theory.nn_to_semis Semi
0, Semi -> Semi
Theory.nn_to_semis Semi
127)

type Keys = Map Pitch.Key Theory.Key

make_keys :: TheoryFormat.Format -> [Theory.Key] -> Keys
make_keys :: Format -> [Key] -> Keys
make_keys Format
fmt [Key]
keys =
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map (Format -> Key -> Key
TheoryFormat.show_key Format
fmt) [Key]
keys) [Key]
keys

make_scale :: Pitch.ScaleId -> ScaleMap -> Doc.Doc -> Scale.Scale
make_scale :: ScaleId -> ScaleMap -> Doc -> Scale
make_scale ScaleId
scale_id ScaleMap
smap Doc
doc = Scale.Scale
    { scale_id :: ScaleId
scale_id = ScaleId
scale_id
    , scale_pattern :: Text
scale_pattern = Format -> Text
TheoryFormat.fmt_pattern (ScaleMap -> Format
smap_fmt ScaleMap
smap)
    , scale_symbols :: [Symbol]
scale_symbols = []
    , scale_transposers :: Set Control
scale_transposers = Set Control
Scales.standard_transposers
    , scale_read :: Environ -> Note -> Either PitchError Pitch
scale_read = ScaleMap -> Maybe Key -> Note -> Either PitchError Pitch
read_pitch ScaleMap
smap forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environ -> Maybe Key
Scales.environ_key
    , scale_show :: Environ -> Pitch -> Either PitchError Note
scale_show = ScaleMap -> Maybe Key -> Pitch -> Either PitchError Note
show_pitch ScaleMap
smap forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environ -> Maybe Key
Scales.environ_key
    , scale_bottom :: Pitch
scale_bottom = Layout -> Semi -> Pitch
Theory.semis_to_pitch_sharps (ScaleMap -> Layout
smap_layout ScaleMap
smap)
        (forall a b. (a, b) -> a
fst (ScaleMap -> (Semi, Semi)
smap_range ScaleMap
smap))
    , scale_layout :: Intervals
scale_layout = Layout -> Intervals
Theory.layout_intervals (ScaleMap -> Layout
smap_layout ScaleMap
smap)
    , scale_transpose :: Transpose
scale_transpose = ScaleMap -> Transpose
transpose ScaleMap
smap
    , scale_enharmonics :: Enharmonics
scale_enharmonics = ScaleMap -> Enharmonics
enharmonics ScaleMap
smap
    , scale_note_to_call :: Note -> Maybe ValCall
scale_note_to_call = Scale -> ScaleMap -> Note -> Maybe ValCall
note_to_call Scale
scale ScaleMap
smap
    , scale_input_to_note :: Environ -> Input -> Either PitchError Note
scale_input_to_note = ScaleMap -> Environ -> Input -> Either PitchError Note
input_to_note ScaleMap
smap
    , scale_input_to_nn :: ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
scale_input_to_nn = (Environ -> Input -> Either PitchError Note)
-> (Note -> Maybe ValCall)
-> ScoreTime
-> Input
-> Deriver (Either PitchError NoteNumber)
Scales.computed_input_to_nn
        (ScaleMap -> Environ -> Input -> Either PitchError Note
input_to_note ScaleMap
smap) (Scale -> ScaleMap -> Note -> Maybe ValCall
note_to_call Scale
scale ScaleMap
smap)
    , scale_call_doc :: DocumentedCall
scale_call_doc = Set Control -> ScaleMap -> Doc -> DocumentedCall
call_doc Set Control
Scales.standard_transposers ScaleMap
smap Doc
doc
    }
    where scale :: Scale
scale = ScaleId -> Set Control -> Scale
PSignal.Scale ScaleId
scale_id Set Control
Scales.standard_transposers

-- * functions

transpose :: ScaleMap -> Derive.Transpose
transpose :: ScaleMap -> Transpose
transpose ScaleMap
smap Transposition
transposition Environ
env Semi
steps Pitch
pitch = do
    Key
key <- ScaleMap -> Environ -> Either PitchError Key
read_environ_key ScaleMap
smap Environ
env
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Key -> Semi -> Pitch -> Pitch
trans Key
key Semi
steps Pitch
pitch
    where
    trans :: Key -> Semi -> Pitch -> Pitch
trans = case Transposition
transposition of
        Transposition
Scale.Chromatic -> Key -> Semi -> Pitch -> Pitch
Theory.transpose_chromatic
        Transposition
Scale.Diatonic -> Key -> Semi -> Pitch -> Pitch
Theory.transpose_diatonic

enharmonics :: ScaleMap -> Derive.Enharmonics
enharmonics :: ScaleMap -> Enharmonics
enharmonics ScaleMap
smap Environ
env Note
note = do
    Pitch
pitch <- ScaleMap -> Maybe Key -> Note -> Either PitchError Pitch
read_pitch ScaleMap
smap (Environ -> Maybe Key
Scales.environ_key Environ
env) Note
note
    Key
key <- ScaleMap -> Environ -> Either PitchError Key
read_environ_key ScaleMap
smap Environ
env
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> [b]
Either.rights forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (ScaleMap -> Maybe Key -> Pitch -> Either PitchError Note
show_pitch ScaleMap
smap (Environ -> Maybe Key
Scales.environ_key Environ
env)) forall a b. (a -> b) -> a -> b
$
        Layout -> Pitch -> [Pitch]
Theory.enharmonics_of (Key -> Layout
Theory.key_layout Key
key) Pitch
pitch

note_to_call :: PSignal.Scale -> ScaleMap -> Pitch.Note -> Maybe Derive.ValCall
note_to_call :: Scale -> ScaleMap -> Note -> Maybe ValCall
note_to_call Scale
scale ScaleMap
smap Note
note =
    case Format -> Note -> Either PitchError RelativePitch
TheoryFormat.read_relative_pitch (ScaleMap -> Format
smap_fmt ScaleMap
smap) Note
note of
        Left PitchError
_ -> forall a. Maybe a
Nothing
        Right RelativePitch
relative -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Scale -> PitchNn -> PitchNote -> ValCall
ScaleDegree.scale_degree Scale
scale
            (ScaleMap -> RelativePitch -> PitchNn
pitch_nn ScaleMap
smap RelativePitch
relative) (ScaleMap -> RelativePitch -> PitchNote
pitch_note ScaleMap
smap RelativePitch
relative)

-- | Create a PitchNote for 'ScaleDegree.scale_degree'.
pitch_note :: ScaleMap -> TheoryFormat.RelativePitch -> Scale.PitchNote
pitch_note :: ScaleMap -> RelativePitch -> PitchNote
pitch_note ScaleMap
smap RelativePitch
relative (PSignal.PitchConfig Environ
env ControlValMap
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 :: Pitch
pitch = RelativePitch -> Pitch
TheoryFormat.relative_to_absolute RelativePitch
relative
    let maybe_key :: Maybe Key
maybe_key = Environ -> Maybe Key
Scales.environ_key Environ
env
    let c :: Semi
c = forall a b. (RealFrac a, Integral b) => a -> b
round Y
chromatic
        o :: Semi
o = forall a b. (RealFrac a, Integral b) => a -> b
round Y
octave
        d :: Semi
d = forall a b. (RealFrac a, Integral b) => a -> b
round Y
diatonic
    -- Symbolic pitch is still relative, so while I transpose with the key,
    -- I don't give it to 'show_pitch'.
    ScaleMap -> Maybe Key -> Pitch -> Either PitchError Note
show_pitch ScaleMap
smap forall a. Maybe a
Nothing forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< if Semi
o forall a. Eq a => a -> a -> Bool
== Semi
0 Bool -> Bool -> Bool
&& Semi
d forall a. Eq a => a -> a -> Bool
== Semi
0 Bool -> Bool -> Bool
&& Semi
c forall a. Eq a => a -> a -> Bool
== Semi
0
        then forall (m :: * -> *) a. Monad m => a -> m a
return Pitch
pitch
        else do
            Key
key <- ScaleMap -> Maybe Key -> Either PitchError Key
read_key ScaleMap
smap Maybe Key
maybe_key
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Semi -> Pitch -> Pitch
Pitch.add_octave Semi
o forall a b. (a -> b) -> a -> b
$ Key -> Semi -> Pitch -> Pitch
Theory.transpose_chromatic Key
key Semi
c forall a b. (a -> b) -> a -> b
$
                Key -> Semi -> Pitch -> Pitch
Theory.transpose_diatonic Key
key Semi
d Pitch
pitch
    where
    octave :: Y
octave = Control -> Y
get Control
Controls.octave
    chromatic :: Y
chromatic = Control -> Y
get Control
Controls.chromatic
    diatonic :: Y
diatonic = Control -> Y
get Control
Controls.diatonic
    get :: Control -> Y
get Control
m = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Y
0 Control
m ControlValMap
controls

-- | Create a PitchNn for 'ScaleDegree.scale_degree'.
pitch_nn :: ScaleMap -> TheoryFormat.RelativePitch -> Scale.PitchNn
pitch_nn :: ScaleMap -> RelativePitch -> PitchNn
pitch_nn ScaleMap
smap RelativePitch
relative config :: PitchConfig
config@(PSignal.PitchConfig Environ
env ControlValMap
controls) = do
    let maybe_key :: Maybe Key
maybe_key = Environ -> Maybe Key
Scales.environ_key Environ
env
    Pitch
pitch <- Format -> Maybe Key -> RelativePitch -> Either PitchError Pitch
TheoryFormat.fmt_to_absolute (ScaleMap -> Format
smap_fmt ScaleMap
smap) Maybe Key
maybe_key RelativePitch
relative
    Y
dsteps <- if Y
diatonic forall a. Eq a => a -> a -> Bool
== Y
0 then forall a b. b -> Either a b
Right Y
0 else do
        Key
key <- ScaleMap -> Maybe Key -> Either PitchError Key
read_key ScaleMap
smap Maybe Key
maybe_key
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Key -> Degree -> Y -> Y
Theory.diatonic_to_chromatic Key
key
            (Pitch -> Degree
Pitch.pitch_degree Pitch
pitch) Y
diatonic
    let semis :: Semi
semis = Layout -> Pitch -> Semi
Theory.pitch_to_semis (ScaleMap -> Layout
smap_layout ScaleMap
smap) Pitch
pitch
        degree :: Y
degree = Y
octave forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Semi
per_octave
            forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Semi
semis forall a. Num a => a -> a -> a
+ Y
chromatic forall a. Num a => a -> a -> a
+ Y
dsteps
    ScaleMap -> SemisToNoteNumber
smap_semis_to_nn ScaleMap
smap PitchConfig
config Y
degree
    where
    octave :: Y
octave = Control -> Y
get Control
Controls.octave
    chromatic :: Y
chromatic = Control -> Y
get Control
Controls.chromatic
    diatonic :: Y
diatonic = Control -> Y
get Control
Controls.diatonic
    get :: Control -> Y
get Control
m = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Y
0 Control
m ControlValMap
controls
    per_octave :: Semi
per_octave = Layout -> Semi
Theory.layout_semis_per_octave (ScaleMap -> Layout
smap_layout ScaleMap
smap)

input_to_note :: ScaleMap -> Scales.InputToNote
input_to_note :: ScaleMap -> Environ -> Input -> Either PitchError Note
input_to_note ScaleMap
smap Environ
env (Pitch.Input KbdType
kbd_type Pitch
pitch Y
frac) = do
    forall a (m :: * -> *).
(HasCallStack, Show a, Monad m) =>
Text -> a -> m ()
Debug.traceM Text
"input_to_note pre" Pitch
pitch
    Pitch
pitch <- KbdType -> Semi -> Semi -> Pitch -> Either PitchError Pitch
Scales.kbd_to_scale KbdType
kbd_type Semi
pc_per_octave (Key -> Semi
key_tonic Key
key) Pitch
pitch
    forall a (m :: * -> *).
(HasCallStack, Show a, Monad m) =>
Text -> a -> m ()
Debug.traceM Text
"input_to_note post" Pitch
pitch
    let intervals :: Intervals
intervals = if Bool
is_relative
            then Key -> Intervals
Theory.key_intervals Key
key
            else Layout -> Intervals
Theory.layout_intervals (ScaleMap -> Layout
smap_layout ScaleMap
smap)
    forall a (m :: * -> *).
(HasCallStack, Show a, Monad m) =>
Text -> a -> m ()
Debug.traceM Text
"intervals" (Bool
is_relative, Intervals
intervals)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Intervals -> Degree -> Bool
Theory.contains_degree Intervals
intervals (Pitch -> Degree
Pitch.pitch_degree Pitch
pitch)
            Bool -> Bool -> Bool
&& ScaleMap -> Pitch -> Bool
in_range ScaleMap
smap Pitch
pitch) forall a b. (a -> b) -> a -> b
$
        forall a b. a -> Either a b
Left PitchError
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 :: Pitch -> Pitch
pick_enharmonic = if Bool
is_relative then forall a. a -> a
id else Key -> Pitch -> Pitch
Theory.pick_enharmonic Key
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
note <- forall {b}. Either PitchError b -> Either PitchError b
invalid_input forall a b. (a -> b) -> a -> b
$ ScaleMap -> Maybe Key -> Pitch -> Either PitchError Note
show_pitch ScaleMap
smap
        (if Bool
is_relative then forall a. Maybe a
Nothing else (Environ -> Maybe Key
Scales.environ_key Environ
env))
        (Pitch -> Pitch
pick_enharmonic Pitch
pitch)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Y -> Note -> Note
ScaleDegree.pitch_expr Y
frac Note
note
    where
    is_relative :: Bool
is_relative = Format -> Bool
TheoryFormat.fmt_relative (ScaleMap -> Format
smap_fmt ScaleMap
smap)
    invalid_input :: Either PitchError b -> Either PitchError b
invalid_input (Left (DeriveT.OutOfRangeError {})) =
        forall a b. a -> Either a b
Left PitchError
DeriveT.InvalidInput
    invalid_input Either PitchError b
x = Either PitchError b
x
    pc_per_octave :: Semi
pc_per_octave = Layout -> Semi
Theory.layout_pc_per_octave (ScaleMap -> Layout
smap_layout ScaleMap
smap)
    -- Default to a key because otherwise you couldn't enter notes in an
    -- empty score!
    key :: Key
key = forall a. a -> Maybe a -> a
fromMaybe (ScaleMap -> Key
smap_default_key ScaleMap
smap) forall a b. (a -> b) -> a -> b
$
        forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ScaleMap -> Keys
smap_keys ScaleMap
smap) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Environ -> Maybe Key
Scales.environ_key Environ
env

in_range :: ScaleMap -> Pitch.Pitch -> Bool
in_range :: ScaleMap -> Pitch -> Bool
in_range ScaleMap
smap Pitch
pitch = Semi
bottom forall a. Ord a => a -> a -> Bool
<= Semi
semis Bool -> Bool -> Bool
&& Semi
semis forall a. Ord a => a -> a -> Bool
<= Semi
top
    where
    (Semi
bottom, Semi
top) = ScaleMap -> (Semi, Semi)
smap_range ScaleMap
smap
    semis :: Semi
semis = Layout -> Pitch -> Semi
Theory.pitch_to_semis (ScaleMap -> Layout
smap_layout ScaleMap
smap) Pitch
pitch

call_doc :: Set ScoreT.Control -> ScaleMap -> Doc.Doc -> Derive.DocumentedCall
call_doc :: Set Control -> ScaleMap -> Doc -> DocumentedCall
call_doc Set Control
transposers ScaleMap
smap Doc
doc =
    Set Control
-> Doc -> [(Doc, Doc)] -> DocumentedCall -> DocumentedCall
Scales.annotate_call_doc Set Control
transposers Doc
doc [(Doc, Doc)]
fields DocumentedCall
call_doc
    where
    call_doc :: DocumentedCall
call_doc = (Scale -> PitchNn -> PitchNote -> ValCall) -> DocumentedCall
Scales.scale_degree_doc Scale -> PitchNn -> PitchNote -> ValCall
ScaleDegree.scale_degree
    -- Not efficient, but shouldn't matter for docs.
    default_key :: Maybe Key
default_key = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((forall a. Eq a => a -> a -> Bool
== ScaleMap -> Key
smap_default_key ScaleMap
smap) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
        (forall k a. Map k a -> [(k, a)]
Map.toList (ScaleMap -> Keys
smap_keys ScaleMap
smap))
    (Semi
bottom, Semi
top) = ScaleMap -> (Semi, Semi)
smap_range ScaleMap
smap
    show_p :: Semi -> Doc
show_p = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Pretty a => a -> Doc
Doc.pretty forall a. Pretty a => a -> Doc
Doc.pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScaleMap -> Maybe Key -> Pitch -> Either PitchError Note
show_pitch ScaleMap
smap forall a. Maybe a
Nothing
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Layout -> Semi -> Pitch
Theory.semis_to_pitch_sharps (ScaleMap -> Layout
smap_layout ScaleMap
smap)
    fields :: [(Doc, Doc)]
fields = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [(Doc
"range", Semi -> Doc
show_p Semi
bottom forall a. Semigroup a => a -> a -> a
<> Doc
" to " forall a. Semigroup a => a -> a -> a
<> Semi -> Doc
show_p Semi
top)]
        , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Key
n -> [(Doc
"default key", forall a. ShowVal a => a -> Doc
ShowVal.doc Key
n)]) Maybe Key
default_key
        , [ (Doc
"keys", [Key] -> Doc
format_keys forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys (ScaleMap -> Keys
smap_keys ScaleMap
smap)) ]
        ]

format_keys :: [Pitch.Key] -> Doc.Doc
format_keys :: [Key] -> Doc
format_keys [Key]
keys
    | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Text
"-" `Text.isInfixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
Pitch.key_text) [Key]
keys = [Doc] -> Doc
Doc.commas forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (Text -> Doc
Doc.literal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a. [(Key, a)] -> [(Text, a)]
group_tonic_mode forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (, ()) [Key]
keys
    | Bool
otherwise = [Doc] -> Doc
Doc.commas (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
Doc.pretty [Key]
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 :: forall a. [(Key, a)] -> [(Text, a)]
group_tonic_mode = forall a b. (a -> b) -> [a] -> [b]
map forall {b} {b}. (Text, [((Text, b), b)]) -> (Text, b)
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])]
Lists.keyedGroupSort forall {a} {b} {b}. ((a, b), b) -> b
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Key -> (Text, Text)
split)
    where
    extract :: (Text, [((Text, b), b)]) -> (Text, b)
extract (Text
mode, [((Text, b), b)]
group) = (Text -> [Text] -> Text
fmt Text
mode (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [((Text, b), b)]
group), forall a b. (a, b) -> b
snd (forall a. [a] -> a
head [((Text, b), b)]
group))
    key :: ((a, b), b) -> b
key ((a
_, b
mode), b
_) = b
mode
    split :: Key -> (Text, Text)
split (Pitch.Key Text
t) = (Text
pre, Semi -> Text -> Text
Text.drop Semi
1 Text
post)
        where (Text
pre, Text
post) = (Char -> Bool) -> Text -> (Text, Text)
Text.break (forall a. Eq a => a -> a -> Bool
==Char
'-') Text
t
    fmt :: Text -> [Text] -> Text
fmt Text
mode [Text]
keys = Text
"(" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"|" [Text]
keys forall a. Semigroup a => a -> a -> a
<> Text
")-" forall a. Semigroup a => a -> a -> a
<> Text
mode

-- * format

relative_fmt :: Theory.Key -> Keys -> TheoryFormat.RelativeFormat Theory.Key
relative_fmt :: Key -> Keys -> RelativeFormat Key
relative_fmt Key
default_key Keys
all_keys  = TheoryFormat.RelativeFormat
    { rel_config :: Config
rel_config = Config
TheoryFormat.default_config
    , rel_key_config :: KeyConfig Key
rel_key_config = TheoryFormat.KeyConfig
        { key_parse :: Maybe Key -> Either PitchError Key
key_parse = forall key.
key -> Map Key key -> Maybe Key -> Either PitchError key
Scales.get_key Key
default_key Keys
all_keys
        , key_default :: Key
key_default = Key
default_key
        }
    , rel_show_degree :: ShowDegree Key
rel_show_degree = ShowDegree Key
TheoryFormat.show_degree_chromatic
    , rel_to_absolute :: ToAbsolute Key
rel_to_absolute = ToAbsolute Key
TheoryFormat.chromatic_to_absolute
    }

-- * util

key_tonic :: Theory.Key -> Pitch.PitchClass
key_tonic :: Key -> Semi
key_tonic = Degree -> Semi
Pitch.degree_pc forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Degree
Theory.key_tonic

show_pitch :: ScaleMap -> Maybe Pitch.Key -> Pitch.Pitch
    -> Either DeriveT.PitchError Pitch.Note
show_pitch :: ScaleMap -> Maybe Key -> Pitch -> Either PitchError Note
show_pitch ScaleMap
smap Maybe Key
key = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format -> Maybe Key -> Pitch -> Note
TheoryFormat.show_pitch (ScaleMap -> Format
smap_fmt ScaleMap
smap) Maybe Key
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 :: ScaleMap -> Maybe Key -> Note -> Either PitchError Pitch
read_pitch ScaleMap
smap = Format -> Maybe Key -> Note -> Either PitchError Pitch
TheoryFormat.read_pitch (ScaleMap -> Format
smap_fmt ScaleMap
smap)

read_environ_key :: ScaleMap -> Env.Environ
    -> Either DeriveT.PitchError Theory.Key
read_environ_key :: ScaleMap -> Environ -> Either PitchError Key
read_environ_key ScaleMap
smap = forall key.
key -> Map Key key -> Maybe Key -> Either PitchError key
Scales.get_key (ScaleMap -> Key
smap_default_key ScaleMap
smap) (ScaleMap -> Keys
smap_keys ScaleMap
smap)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environ -> Maybe Key
Scales.environ_key

read_key :: ScaleMap -> Maybe Pitch.Key
    -> Either DeriveT.PitchError Theory.Key
read_key :: ScaleMap -> Maybe Key -> Either PitchError Key
read_key ScaleMap
smap = forall key.
key -> Map Key key -> Maybe Key -> Either PitchError key
Scales.get_key (ScaleMap -> Key
smap_default_key ScaleMap
smap) (ScaleMap -> Keys
smap_keys ScaleMap
smap)