-- 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 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.Seq as Seq
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.ScaleMap' 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 -> NoteNumber -> Either PitchError NoteNumber
forall (m :: * -> *) a. Monad m => a -> m a
return (NoteNumber -> Either PitchError NoteNumber)
-> (Y -> NoteNumber) -> Y -> Either PitchError NoteNumber
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 =
    [(Key, Key)] -> Keys
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Key, Key)] -> Keys) -> [(Key, Key)] -> Keys
forall a b. (a -> b) -> a -> b
$ [Key] -> [Key] -> [(Key, Key)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Key -> Key) -> [Key] -> [Key]
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 (Maybe Key -> Note -> Either PitchError Pitch)
-> (Environ -> Maybe Key)
-> Environ
-> Note
-> Either PitchError Pitch
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 (Maybe Key -> Pitch -> Either PitchError Note)
-> (Environ -> Maybe Key)
-> Environ
-> Pitch
-> Either PitchError Note
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)
        ((Semi, Semi) -> Semi
forall a b. (a, b) -> a
fst (ScaleMap -> (Semi, Semi)
smap_range ScaleMap
smap))
    , scale_layout :: Layout
scale_layout = Layout -> Layout
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
    Pitch -> Either PitchError Pitch
forall (m :: * -> *) a. Monad m => a -> m a
return (Pitch -> Either PitchError Pitch)
-> Pitch -> Either PitchError Pitch
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
    [Note] -> Either PitchError [Note]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Note] -> Either PitchError [Note])
-> [Note] -> Either PitchError [Note]
forall a b. (a -> b) -> a -> b
$ [Either PitchError Note] -> [Note]
forall a b. [Either a b] -> [b]
Either.rights ([Either PitchError Note] -> [Note])
-> [Either PitchError Note] -> [Note]
forall a b. (a -> b) -> a -> b
$ (Pitch -> Either PitchError Note)
-> [Pitch] -> [Either PitchError Note]
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)) ([Pitch] -> [Either PitchError Note])
-> [Pitch] -> [Either PitchError Note]
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
_ -> Maybe ValCall
forall a. Maybe a
Nothing
        Right RelativePitch
relative -> ValCall -> Maybe ValCall
forall a. a -> Maybe a
Just (ValCall -> Maybe ValCall) -> ValCall -> Maybe ValCall
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 = Y -> Semi
forall a b. (RealFrac a, Integral b) => a -> b
round Y
chromatic
        o :: Semi
o = Y -> Semi
forall a b. (RealFrac a, Integral b) => a -> b
round Y
octave
        d :: Semi
d = Y -> Semi
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 Maybe Key
forall a. Maybe a
Nothing (Pitch -> Either PitchError Note)
-> Either PitchError Pitch -> Either PitchError Note
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< if Semi
o Semi -> Semi -> Bool
forall a. Eq a => a -> a -> Bool
== Semi
0 Bool -> Bool -> Bool
&& Semi
d Semi -> Semi -> Bool
forall a. Eq a => a -> a -> Bool
== Semi
0 Bool -> Bool -> Bool
&& Semi
c Semi -> Semi -> Bool
forall a. Eq a => a -> a -> Bool
== Semi
0
        then Pitch -> Either PitchError Pitch
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
            Pitch -> Either PitchError Pitch
forall (m :: * -> *) a. Monad m => a -> m a
return (Pitch -> Either PitchError Pitch)
-> Pitch -> Either PitchError Pitch
forall a b. (a -> b) -> a -> b
$ Semi -> Pitch -> Pitch
Pitch.add_octave Semi
o (Pitch -> Pitch) -> Pitch -> Pitch
forall a b. (a -> b) -> a -> b
$ Key -> Semi -> Pitch -> Pitch
Theory.transpose_chromatic Key
key Semi
c (Pitch -> Pitch) -> Pitch -> Pitch
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 = Y -> Control -> ControlValMap -> Y
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 Y -> Y -> Bool
forall a. Eq a => a -> a -> Bool
== Y
0 then Y -> Either PitchError Y
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
        Y -> Either PitchError Y
forall (m :: * -> *) a. Monad m => a -> m a
return (Y -> Either PitchError Y) -> Y -> Either PitchError Y
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 Y -> Y -> Y
forall a. Num a => a -> a -> a
* Semi -> Y
forall a b. (Integral a, Num b) => a -> b
fromIntegral Semi
per_octave
            Y -> Y -> Y
forall a. Num a => a -> a -> a
+ Semi -> Y
forall a b. (Integral a, Num b) => a -> b
fromIntegral Semi
semis Y -> Y -> Y
forall a. Num a => a -> a -> a
+ Y
chromatic Y -> Y -> Y
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 = Y -> Control -> ControlValMap -> Y
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
    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
    let intervals :: Layout
intervals = if Bool
is_relative
            then Key -> Layout
Theory.key_intervals Key
key
            else Layout -> Layout
Theory.layout_intervals (ScaleMap -> Layout
smap_layout ScaleMap
smap)
    Bool -> Either PitchError () -> Either PitchError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Layout -> Degree -> Bool
Theory.contains_degree Layout
intervals (Pitch -> Degree
Pitch.pitch_degree Pitch
pitch)
            Bool -> Bool -> Bool
&& ScaleMap -> Pitch -> Bool
in_range ScaleMap
smap Pitch
pitch) (Either PitchError () -> Either PitchError ())
-> Either PitchError () -> Either PitchError ()
forall a b. (a -> b) -> a -> b
$
        PitchError -> Either PitchError ()
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 Pitch -> Pitch
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 <- Either PitchError Note -> Either PitchError Note
forall {b}. Either PitchError b -> Either PitchError b
invalid_input (Either PitchError Note -> Either PitchError Note)
-> Either PitchError Note -> Either PitchError Note
forall a b. (a -> b) -> a -> b
$ ScaleMap -> Maybe Key -> Pitch -> Either PitchError Note
show_pitch ScaleMap
smap
        (if Bool
is_relative then Maybe Key
forall a. Maybe a
Nothing else (Environ -> Maybe Key
Scales.environ_key Environ
env))
        (Pitch -> Pitch
pick_enharmonic Pitch
pitch)
    Note -> Either PitchError Note
forall (m :: * -> *) a. Monad m => a -> m a
return (Note -> Either PitchError Note) -> Note -> Either PitchError Note
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 {})) =
        PitchError -> Either PitchError b
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 = Key -> Maybe Key -> Key
forall a. a -> Maybe a -> a
fromMaybe (ScaleMap -> Key
smap_default_key ScaleMap
smap) (Maybe Key -> Key) -> Maybe Key -> Key
forall a b. (a -> b) -> a -> b
$
        (Key -> Keys -> Maybe Key) -> Keys -> Key -> Maybe Key
forall a b c. (a -> b -> c) -> b -> a -> c
flip Key -> Keys -> Maybe Key
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ScaleMap -> Keys
smap_keys ScaleMap
smap) (Key -> Maybe Key) -> Maybe Key -> Maybe Key
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 Semi -> Semi -> Bool
forall a. Ord a => a -> a -> Bool
<= Semi
semis Bool -> Bool -> Bool
&& Semi
semis Semi -> Semi -> Bool
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 = (Key, Key) -> Key
forall a b. (a, b) -> a
fst ((Key, Key) -> Key) -> Maybe (Key, Key) -> Maybe Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Key, Key) -> Bool) -> [(Key, Key)] -> Maybe (Key, Key)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
== ScaleMap -> Key
smap_default_key ScaleMap
smap) (Key -> Bool) -> ((Key, Key) -> Key) -> (Key, Key) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, Key) -> Key
forall a b. (a, b) -> b
snd)
        (Keys -> [(Key, Key)]
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 = (PitchError -> Doc)
-> (Note -> Doc) -> Either PitchError Note -> Doc
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either PitchError -> Doc
forall a. Pretty a => a -> Doc
Doc.pretty Note -> Doc
forall a. Pretty a => a -> Doc
Doc.pretty (Either PitchError Note -> Doc)
-> (Semi -> Either PitchError Note) -> Semi -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScaleMap -> Maybe Key -> Pitch -> Either PitchError Note
show_pitch ScaleMap
smap Maybe Key
forall a. Maybe a
Nothing
        (Pitch -> Either PitchError Note)
-> (Semi -> Pitch) -> Semi -> Either PitchError Note
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 = [[(Doc, Doc)]] -> [(Doc, Doc)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [(Doc
"range", Semi -> Doc
show_p Semi
bottom Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
" to " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Semi -> Doc
show_p Semi
top)]
        , [(Doc, Doc)] -> (Key -> [(Doc, Doc)]) -> Maybe Key -> [(Doc, Doc)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Key
n -> [(Doc
"default key", Key -> Doc
forall a. ShowVal a => a -> Doc
ShowVal.doc Key
n)]) Maybe Key
default_key
        , [ (Doc
"keys", [Key] -> Doc
format_keys ([Key] -> Doc) -> [Key] -> Doc
forall a b. (a -> b) -> a -> b
$ Keys -> [Key]
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
    | (Key -> Bool) -> [Key] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Text
"-" `Text.isInfixOf`) (Text -> Bool) -> (Key -> Text) -> Key -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
Pitch.key_text) [Key]
keys = [Doc] -> Doc
Doc.commas ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
        ((Text, ()) -> Doc) -> [(Text, ())] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Doc
Doc.literal (Text -> Doc) -> ((Text, ()) -> Text) -> (Text, ()) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, ()) -> Text
forall a b. (a, b) -> a
fst) ([(Text, ())] -> [Doc]) -> [(Text, ())] -> [Doc]
forall a b. (a -> b) -> a -> b
$ [(Key, ())] -> [(Text, ())]
forall a. [(Key, a)] -> [(Text, a)]
group_tonic_mode ([(Key, ())] -> [(Text, ())]) -> [(Key, ())] -> [(Text, ())]
forall a b. (a -> b) -> a -> b
$ (Key -> (Key, ())) -> [Key] -> [(Key, ())]
forall a b. (a -> b) -> [a] -> [b]
map (, ()) [Key]
keys
    | Bool
otherwise = [Doc] -> Doc
Doc.commas ((Key -> Doc) -> [Key] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Key -> Doc
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 = ((Text, [((Text, Text), a)]) -> (Text, a))
-> [(Text, [((Text, Text), a)])] -> [(Text, a)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, [((Text, Text), a)]) -> (Text, a)
forall {b} {b}. (Text, [((Text, b), b)]) -> (Text, b)
extract ([(Text, [((Text, Text), a)])] -> [(Text, a)])
-> ([(Key, a)] -> [(Text, [((Text, Text), a)])])
-> [(Key, a)]
-> [(Text, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((Text, Text), a) -> Text)
-> [((Text, Text), a)] -> [(Text, [((Text, Text), a)])]
forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])]
Seq.keyed_group_sort ((Text, Text), a) -> Text
forall {a} {b} {b}. ((a, b), b) -> b
key ([((Text, Text), a)] -> [(Text, [((Text, Text), a)])])
-> ([(Key, a)] -> [((Text, Text), a)])
-> [(Key, a)]
-> [(Text, [((Text, Text), a)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, a) -> ((Text, Text), a))
-> [(Key, a)] -> [((Text, Text), a)]
forall a b. (a -> b) -> [a] -> [b]
map ((Key -> (Text, Text)) -> (Key, a) -> ((Text, Text), a)
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 ((((Text, b), b) -> Text) -> [((Text, b), b)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text, b) -> Text
forall a b. (a, b) -> a
fst ((Text, b) -> Text)
-> (((Text, b), b) -> (Text, b)) -> ((Text, b), b) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, b), b) -> (Text, b)
forall a b. (a, b) -> a
fst) [((Text, b), b)]
group), ((Text, b), b) -> b
forall a b. (a, b) -> b
snd ([((Text, b), b)] -> ((Text, b), b)
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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'-') Text
t
    fmt :: Text -> [Text] -> Text
fmt Text
mode [Text]
keys = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"|" [Text]
keys Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")-" Text -> Text -> 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 = Key -> Keys -> Maybe Key -> Either PitchError Key
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
    }

-- * implementation

key_tonic :: Theory.Key -> Pitch.PitchClass
key_tonic :: Key -> Semi
key_tonic = Degree -> Semi
Pitch.degree_pc (Degree -> Semi) -> (Key -> Degree) -> Key -> Semi
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 = Note -> Either PitchError Note
forall a b. b -> Either a b
Right (Note -> Either PitchError Note)
-> (Pitch -> Note) -> Pitch -> Either PitchError Note
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 = Key -> Keys -> Maybe Key -> Either PitchError Key
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)
    (Maybe Key -> Either PitchError Key)
-> (Environ -> Maybe Key) -> Environ -> Either PitchError Key
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 = Key -> Keys -> Maybe Key -> Either PitchError Key
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)