-- 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

module Derive.Scale.JustScales where
import qualified Data.Map as Map
import qualified Data.Ratio as Ratio
import           Data.Ratio ((%))
import qualified Data.Text as Text
import qualified Data.Vector as Vector

import qualified Util.Doc as Doc
import qualified Util.Num as Num
import qualified Util.Pretty as Pretty
import qualified Util.Lists as Lists
import qualified Util.Texts as Texts

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.EnvKey as EnvKey
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.NN as NN
import qualified Perform.Pitch as Pitch

import           Global


type Ratios = Vector.Vector (Ratio.Ratio Int)

-- | Hz frequency of 1/1.
just_base_control :: ScoreT.Control
just_base_control :: Control
just_base_control = Control
"just-base"

-- | Bundle up data needed to construct a just scale.
data ScaleMap = ScaleMap {
    ScaleMap -> Format
smap_fmt :: TheoryFormat.Format
    , ScaleMap -> Keys
smap_keys :: Keys
    , ScaleMap -> Key
smap_default_key :: Key
    -- | Use this Tuning if there is no EnvKey.tuning.  If Nothing, don't even
    -- look for EnvKey.tuning, and use "" for 'key_ratios'.
    , ScaleMap -> Maybe Text
smap_default_tuning :: Maybe Tuning
    -- | Previously I would default to the 12TET of the tonic when just-base
    -- isn't set, but that doesn't work when the scale doesn't use 12TET names.
    , ScaleMap -> Hz
smap_default_base_hz :: Pitch.Hz
    , ScaleMap -> NamedIntervals
smap_named_intervals :: ScaleDegree.NamedIntervals
    -- | Sharps multiply by this, flats divide by this.
    --
    -- While these scales recognize sharps and flats, and 'input_to_note' will
    -- create them, they are still considered diatonic scales, and the
    -- accidentals are not considered part of the scale.  So chromatic
    -- transposition is treated the same as diatonic transposition, and you
    -- can't root a key on a note with an accidental.
    , ScaleMap -> Hz
smap_accidental_interval :: Double
    }

type Tuning = Text
type Keys = Map Pitch.Key Key

-- | Make a just scale with the given set of keys.  A \"key\" in a just scale
-- is the set of ratios and the tonic.  The number of ratios should be the same
-- as the number of scale degrees as defined by the 'TheoryFormat.Format'.  If
-- there are too many, the extras will never be reached, if too few, they'll
-- wrap around.
scale_map :: Keys -> Key -> Maybe Tuning -> TheoryFormat.Format -> ScaleMap
scale_map :: Keys -> Key -> Maybe Text -> Format -> ScaleMap
scale_map Keys
keys Key
default_key Maybe Text
default_tuning Format
fmt = 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_default_tuning :: Maybe Text
smap_default_tuning = Maybe Text
default_tuning
    , smap_default_base_hz :: Hz
smap_default_base_hz = NoteNumber -> Hz
Pitch.nn_to_hz NoteNumber
NN.middle_c
    , smap_named_intervals :: NamedIntervals
smap_named_intervals = NamedIntervals
default_named_intervals
    , smap_accidental_interval :: Hz
smap_accidental_interval = Hz
16 forall a. Fractional a => a -> a -> a
/ Hz
15
    }

-- | TODO this should be 'repeat 2', but as long as this is also controlling
-- the input layout, it has to be piano layout, or it won't work properly with
-- kbd and midi entry.
layout :: Theory.Layout
layout :: Layout
layout = Layout
Theory.piano_layout

make_scale :: Pitch.ScaleId -> ScaleMap -> Doc.Doc -> [(Doc.Doc, Doc.Doc)]
    -> Scale.Scale
make_scale :: ScaleId -> ScaleMap -> Doc -> [(Doc, Doc)] -> Scale
make_scale ScaleId
scale_id ScaleMap
smap Doc
doc [(Doc, Doc)]
doc_fields = Scale.Scale
    { scale_id :: ScaleId
scale_id = ScaleId
scale_id
    , scale_pattern :: Text
scale_pattern = Format -> Text
TheoryFormat.fmt_pattern Format
fmt
    , 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 = Format -> Maybe Key -> Note -> Either PitchError Pitch
TheoryFormat.read_pitch Format
fmt 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 = Format -> Maybe Key -> Pitch -> Either PitchError Note
TheoryFormat.scale_show_pitch Format
fmt forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environ -> Maybe Key
Scales.environ_key
    , scale_bottom :: Pitch
scale_bottom = Layout -> Tonic -> Pitch
Theory.semis_to_pitch_sharps Layout
layout forall a b. (a -> b) -> a -> b
$ Tonic -> Tonic
Theory.nn_to_semis Tonic
0
    , scale_layout :: Layout
scale_layout = Tonic -> Layout
Scale.diatonic_layout forall a b. (a -> b) -> a -> b
$ Format -> Tonic
TheoryFormat.fmt_pc_per_octave Format
fmt
    , scale_transpose :: Transpose
scale_transpose = Format -> Transpose
transpose Format
fmt
    , scale_enharmonics :: Enharmonics
scale_enharmonics = Layout -> Format -> Enharmonics
enharmonics Layout
layout Format
fmt
    , 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
-> Doc -> [(Doc, Doc)] -> DocumentedCall -> DocumentedCall
Scales.annotate_call_doc Set Control
Scales.standard_transposers
        Doc
all_doc [(Doc, Doc)]
doc_fields DocumentedCall
dummy_call
    }
    where
    all_doc :: Doc
all_doc = forall a. Monoid a => [a] -> a
mconcat [Doc
doc, Doc
"\n", Doc
defaults_doc, Doc
"\n", Doc
just_doc]
    defaults_doc :: Doc
defaults_doc = forall a. Textlike a => a -> [a] -> a
Texts.join Doc
", " forall a b. (a -> b) -> a -> b
$
        [ Doc
"Defaults: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Control
just_base_control forall a. Semigroup a => a -> a -> a
<> Doc
": "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
Doc.pretty (ScaleMap -> Hz
smap_default_base_hz ScaleMap
smap)
        -- TODO This should be the symbolic key name, but I don't have it here.
        , Doc
"key: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
Doc.pretty (ScaleMap -> Key
smap_default_key ScaleMap
smap)
        ] forall a. [a] -> [a] -> [a]
++ case ScaleMap -> Maybe Text
smap_default_tuning ScaleMap
smap of
            Maybe Text
Nothing -> []
            Just Text
deflt -> [Doc
"tuning: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Text
deflt]
    scale :: Scale
scale = ScaleId -> Set Control -> Scale
PSignal.Scale ScaleId
scale_id Set Control
Scales.standard_transposers
    dummy_call :: DocumentedCall
dummy_call = (Scale -> PitchNn -> PitchNote -> ValCall) -> DocumentedCall
Scales.scale_degree_doc forall a b. (a -> b) -> a -> b
$ \Scale
scale ->
        Scale -> NamedIntervals -> Hz -> PitchNn -> PitchNote -> ValCall
ScaleDegree.scale_degree_just Scale
scale (ScaleMap -> NamedIntervals
smap_named_intervals ScaleMap
smap) Hz
0
    fmt :: Format
fmt = ScaleMap -> Format
smap_fmt ScaleMap
smap

-- | Call doc that assumes I'm using 'default_named_intervals'.
default_call_doc :: Derive.DocumentedCall
default_call_doc :: DocumentedCall
default_call_doc = (Scale -> PitchNn -> PitchNote -> ValCall) -> DocumentedCall
Scales.scale_degree_doc forall a b. (a -> b) -> a -> b
$ \Scale
scale ->
    Scale -> NamedIntervals -> Hz -> PitchNn -> PitchNote -> ValCall
ScaleDegree.scale_degree_just Scale
scale NamedIntervals
default_named_intervals Hz
0

-- | Group keys and format them into fields suitable to pass to 'make_scale'.
-- The 'Key's are expected to be relative, so their 'key_tonic's are ignored.
group_relative_keys :: [(Pitch.Key, Key)] -> [(Doc.Doc, Doc.Doc)]
group_relative_keys :: [(Key, Key)] -> [(Doc, Doc)]
group_relative_keys = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe NonEmpty (Key, Key) -> Maybe (Doc, Doc)
fmt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a. Eq key => (a -> key) -> [a] -> [NonEmpty a]
Lists.groupStable forall a b. (a, b) -> b
snd
    where
    fmt :: NonEmpty (Key, Key) -> Maybe (Doc, Doc)
fmt ((Key
name, Key
key) :| [(Key, Key)]
rest) =
        forall a. a -> Maybe a
Just ([Key] -> Doc
fmt_names (Key
name forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Key, Key)]
rest),
            Text -> Doc
Doc.Doc forall a b. (a -> b) -> a -> b
$ Map Text Ratios -> Text
show_ratios (Key -> Map Text Ratios
key_ratios Key
key))
    fmt_names :: [Key] -> Doc
fmt_names = [Doc] -> Doc
Doc.commas forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. ShowVal a => a -> Doc
ShowVal.doc

show_ratios :: Map Tuning Ratios -> Text
show_ratios :: Map Text Ratios -> Text
show_ratios Map Text Ratios
tunings = Text -> [Text] -> Text
Text.intercalate Text
"; "
    [ forall a. Textlike a => a -> a -> a -> a
Texts.join2 Text
": " Text
tuning (Ratios -> Text
ratios Ratios
r)
    | (Text
tuning, Ratios
r) <- forall k a. Map k a -> [(k, a)]
Map.toList Map Text Ratios
tunings
    ]
    where
    ratios :: Ratios -> Text
ratios = Text -> [Text] -> Text
Text.intercalate Text
", " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. (Eq a, Num a, Pretty a) => Ratio a -> Text
Pretty.improperRatio forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Vector a -> [a]
Vector.toList

just_doc :: Doc.Doc
just_doc :: Doc
just_doc =
    Doc
"\nJust scales are tuned by ratios from a base frequency, taken from the "
    forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Control
just_base_control
    forall a. Semigroup a => a -> a -> a
<> Doc
" control, as hz. Typically the \"key\" will select the set\
    \ of ratios used, dependent on the scale.\
    \\nJust scales recognize accidentals as an offset by a fixed ratio,\
    \ but are inherently diatonic, so chromatic transposition is the same\
    \ as diatonic transposition.\
    \\nIf the scale has tuning variations, they are set with the "
    forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Text
EnvKey.tuning forall a. Semigroup a => a -> a -> a
<> Doc
" env var."

-- * input_to_note

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

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 Hz
_frac) = do
    Key
key <- ScaleMap -> Maybe Key -> Either PitchError Key
read_key ScaleMap
smap (Environ -> Maybe Key
Scales.environ_key Environ
env)
    Pitch
pitch <- KbdType -> Tonic -> Tonic -> Pitch -> Either PitchError Pitch
Scales.kbd_to_scale KbdType
kbd_type Tonic
pc_per_octave (Key -> Tonic
key_tonic Key
key) Pitch
pitch
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> Maybe Key -> Pitch -> Note
TheoryFormat.show_pitch (ScaleMap -> Format
smap_fmt ScaleMap
smap) forall a. Maybe a
Nothing Pitch
pitch
    where pc_per_octave :: Tonic
pc_per_octave = Format -> Tonic
TheoryFormat.fmt_pc_per_octave (ScaleMap -> Format
smap_fmt ScaleMap
smap)


-- * transpose

transpose :: TheoryFormat.Format -> Derive.Transpose
transpose :: Format -> Transpose
transpose Format
fmt Transposition
_transposition Environ
_key Tonic
steps Pitch
pitch =
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Tonic -> Tonic -> Pitch -> Pitch
Pitch.add_pc Tonic
per_oct Tonic
steps Pitch
pitch
    where per_oct :: Tonic
per_oct = Format -> Tonic
TheoryFormat.fmt_pc_per_octave Format
fmt

-- * note_to_call

-- | To modulate to another scale: @just-base = (hz (4g)) | key = g-maj@
-- The order is important, so the @(hz (4g))@ happens in the context of the old
-- key.
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 Format
fmt Note
note of
        Left PitchError
_ -> Scale -> NamedIntervals -> Note -> Maybe ValCall
ScaleDegree.scale_degree_interval
            Scale
scale (ScaleMap -> NamedIntervals
smap_named_intervals ScaleMap
smap) Note
note
        Right RelativePitch
relative -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Scale -> NamedIntervals -> Hz -> PitchNn -> PitchNote -> ValCall
ScaleDegree.scale_degree_just
                Scale
scale (ScaleMap -> NamedIntervals
smap_named_intervals ScaleMap
smap)
                (ScaleMap -> Hz
smap_accidental_interval ScaleMap
smap forall a b. (Fractional a, Integral b) => a -> b -> a
^^ Tonic
acc)
                (ScaleMap -> RelativePitch -> PitchNn
pitch_nn ScaleMap
smap RelativePitch
stripped) (Format -> RelativePitch -> PitchNote
pitch_note Format
fmt RelativePitch
stripped)
            where
            (Tonic
acc, RelativePitch
stripped) = case RelativePitch
relative of
                TheoryFormat.RelativePitch Tonic
oct Tonic
pc Maybe Tonic
acc ->
                    (forall a. a -> Maybe a -> a
fromMaybe Tonic
0 Maybe Tonic
acc,
                        Tonic -> Tonic -> Maybe Tonic -> RelativePitch
TheoryFormat.RelativePitch Tonic
oct Tonic
pc (forall a. a -> Maybe a
Just Tonic
0))
    where fmt :: Format
fmt = ScaleMap -> Format
smap_fmt ScaleMap
smap

pitch_nn :: ScaleMap -> TheoryFormat.RelativePitch -> Scale.PitchNn
pitch_nn :: ScaleMap -> RelativePitch -> PitchNn
pitch_nn ScaleMap
smap RelativePitch
relative (PSignal.PitchConfig Environ
env ControlValMap
controls) = do
    Key
key <- ScaleMap -> Maybe Key -> Either PitchError Key
read_key ScaleMap
smap forall a b. (a -> b) -> a -> b
$ Environ -> Maybe Key
Scales.environ_key Environ
env
    Text
tuning <- case ScaleMap -> Maybe Text
smap_default_tuning ScaleMap
smap of
        Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Text
""
        Just Text
deflt -> forall a val.
(Typecheck a, ShowVal a) =>
(a -> Maybe val)
-> Maybe val -> Text -> Environ -> Either PitchError val
Scales.read_environ forall a. a -> a
id (forall a. a -> Maybe a
Just Text
deflt) Text
EnvKey.tuning Environ
env
    Ratios
ratios <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust
        (Text -> Maybe Text -> PitchError
DeriveT.EnvironError Text
EnvKey.tuning
            (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text
"unknown: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Text
tuning))
        (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
tuning (Key -> Map Text Ratios
key_ratios Key
key))
    Pitch
pitch <- Format -> Maybe Key -> RelativePitch -> Either PitchError Pitch
TheoryFormat.fmt_to_absolute (ScaleMap -> Format
smap_fmt ScaleMap
smap)
        (Environ -> Maybe Key
Scales.environ_key Environ
env) RelativePitch
relative
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Hz
base_hz forall a. Eq a => a -> a -> Bool
== Hz
0) forall a b. (a -> b) -> a -> b
$
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Control -> Text -> PitchError
PSignal.ControlError Control
just_base_control Text
"==0"
    let hz :: Hz
hz = Tonic -> Hz -> Tonic -> Ratios -> Hz -> Pitch -> Hz
transpose_to_hz Tonic
per_octave Hz
base_hz
            (Key -> Tonic
key_tonic Key
key) Ratios
ratios
            (Hz
octave forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Tonic
per_octave forall a. Num a => a -> a -> a
+ Hz
chromatic forall a. Num a => a -> a -> a
+ Hz
diatonic) Pitch
pitch
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Hz -> NoteNumber
Pitch.hz_to_nn Hz
hz
    where
    per_octave :: Tonic
per_octave = Format -> Tonic
TheoryFormat.fmt_pc_per_octave (ScaleMap -> Format
smap_fmt ScaleMap
smap)
    octave :: Hz
octave = Control -> Hz
get Control
Controls.octave
    chromatic :: Hz
chromatic = Control -> Hz
get Control
Controls.chromatic
    diatonic :: Hz
diatonic = Control -> Hz
get Control
Controls.diatonic
    get :: Control -> Hz
get Control
m = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Hz
0 Control
m ControlValMap
controls
    base_hz :: Hz
base_hz = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (ScaleMap -> Hz
smap_default_base_hz ScaleMap
smap)
        Control
just_base_control ControlValMap
controls

pitch_note :: TheoryFormat.Format -> TheoryFormat.RelativePitch
    -> Scale.PitchNote
pitch_note :: Format -> RelativePitch -> PitchNote
pitch_note Format
fmt RelativePitch
relative (PSignal.PitchConfig Environ
env ControlValMap
controls) = do
    let maybe_key :: Maybe Key
maybe_key = Environ -> Maybe Key
Scales.environ_key Environ
env
    -- TODO wait, shouldn't I display the relative pitch?
    Pitch
pitch <- Format -> Maybe Key -> RelativePitch -> Either PitchError Pitch
TheoryFormat.fmt_to_absolute Format
fmt Maybe Key
maybe_key RelativePitch
relative
    let transposed :: Pitch
transposed = Tonic -> Tonic -> Pitch -> Pitch
Pitch.add_pc
            (Format -> Tonic
TheoryFormat.fmt_pc_per_octave Format
fmt)
            (forall a b. (RealFrac a, Integral b) => a -> b
round (Hz
chromatic forall a. Num a => a -> a -> a
+ Hz
diatonic)) Pitch
pitch
    forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Format -> Maybe Key -> Pitch -> Note
TheoryFormat.show_pitch Format
fmt Maybe Key
maybe_key Pitch
transposed
    where
    chromatic :: Hz
chromatic = Control -> Hz
get Control
Controls.chromatic
    diatonic :: Hz
diatonic = Control -> Hz
get Control
Controls.diatonic
    get :: Control -> Hz
get Control
m = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Hz
0 Control
m ControlValMap
controls

transpose_to_hz :: Pitch.PitchClass -> Pitch.Hz -> TheoryFormat.Tonic -> Ratios
    -> Double -> Pitch.Pitch -> Pitch.Hz
transpose_to_hz :: Tonic -> Hz -> Tonic -> Ratios -> Hz -> Pitch -> Hz
transpose_to_hz Tonic
per_oct Hz
base_hz Tonic
tonic Ratios
ratios Hz
frac_steps Pitch
pitch =
    forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale Hz
hz1 Hz
hz2 Hz
frac
    where
    -- The 'frac' must be positive for it to fall between pitch1 and pitch2.
    (Tonic
steps, Hz
frac) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
split_fraction Hz
frac_steps
    pitch1 :: Pitch
pitch1 = Tonic -> Tonic -> Pitch -> Pitch
Pitch.add_pc Tonic
per_oct (Tonic
steps forall a. Num a => a -> a -> a
- Tonic
tonic) Pitch
pitch
    pitch2 :: Pitch
pitch2 = Tonic -> Tonic -> Pitch -> Pitch
Pitch.add_pc Tonic
per_oct Tonic
1 Pitch
pitch1
    hz1 :: Hz
hz1 = Ratios -> Hz -> Pitch -> Hz
degree_to_hz Ratios
ratios Hz
base_hz Pitch
pitch1
    hz2 :: Hz
hz2 = Ratios -> Hz -> Pitch -> Hz
degree_to_hz Ratios
ratios Hz
base_hz Pitch
pitch2

-- | Like 'properFraction', but the fraction is always positive.
split_fraction :: (RealFrac a, Integral b) => a -> (b, a)
split_fraction :: forall a b. (RealFrac a, Integral b) => a -> (b, a)
split_fraction a
frac
    | a
f forall a. Ord a => a -> a -> Bool
< a
0 = (b
i forall a. Num a => a -> a -> a
- b
1, a
f forall a. Num a => a -> a -> a
+ a
1)
    | Bool
otherwise = (b
i, a
f)
    where (b
i, a
f) = forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction a
frac

-- | Given a Key, convert a pitch in that key to its hz value, calculated as
-- a ratio from the given base hz.
degree_to_hz :: Ratios -> Pitch.Hz
    -> Pitch.Pitch -- ^ should be relative to scale's tonic
    -> Pitch.Hz
degree_to_hz :: Ratios -> Hz -> Pitch -> Hz
degree_to_hz Ratios
ratios Hz
base_hz Pitch
pitch = Hz
base forall a. Num a => a -> a -> a
* forall a b. (Real a, Fractional b) => a -> b
realToFrac Ratio Tonic
ratio
    where
    base :: Hz
base = Hz
adjusted_base forall a. Num a => a -> a -> a
* Hz
2 forall a b. (Fractional a, Integral b) => a -> b -> a
^^ Pitch -> Tonic
Pitch.pitch_octave Pitch
pitch
    -- Normalize the base_hz to lie within the first octave.
    -- Add an octave because of NOTE [middle-c].
    adjusted_base :: Hz
adjusted_base = NoteNumber -> Hz
Pitch.nn_to_hz forall a b. (a -> b) -> a -> b
$ Hz -> NoteNumber
Pitch.hz_to_nn Hz
base_hz forall a. Real a => a -> a -> a
`Num.fmod` NoteNumber
12 forall a. Num a => a -> a -> a
+ NoteNumber
12
    ratio :: Ratio Tonic
ratio = forall a. Vector a -> Tonic -> a
index_mod Ratios
ratios forall a b. (a -> b) -> a -> b
$ Degree -> Tonic
Pitch.degree_pc (Pitch -> Degree
Pitch.pitch_degree Pitch
pitch)

index_mod :: Vector.Vector a -> Int -> a
index_mod :: forall a. Vector a -> Tonic -> a
index_mod Vector a
v Tonic
i = forall a. Vector a -> Tonic -> a
Vector.unsafeIndex Vector a
v (Tonic
i forall a. Integral a => a -> a -> a
`mod` forall a. Vector a -> Tonic
Vector.length Vector a
v)

-- * key

data Key = Key {
    Key -> Tonic
key_tonic :: TheoryFormat.Tonic
    , Key -> Map Text Ratios
key_ratios :: Map Tuning Ratios
    } deriving (Key -> Key -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Key -> Key -> Bool
$c/= :: Key -> Key -> Bool
== :: Key -> Key -> Bool
$c== :: Key -> Key -> Bool
Eq, Tonic -> Key -> ShowS
[Key] -> ShowS
Key -> String
forall a.
(Tonic -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Key] -> ShowS
$cshowList :: [Key] -> ShowS
show :: Key -> String
$cshow :: Key -> String
showsPrec :: Tonic -> Key -> ShowS
$cshowsPrec :: Tonic -> Key -> ShowS
Show)

instance Pretty Key where
    pretty :: Key -> Text
pretty (Key Tonic
tonic Map Text Ratios
ratios) =
        Text
"(Key " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Tonic
tonic forall a. Semigroup a => a -> a -> a
<> Text
" [" forall a. Semigroup a => a -> a -> a
<> Map Text Ratios -> Text
show_ratios Map Text Ratios
ratios forall a. Semigroup a => a -> a -> a
<> Text
"])"

read_key :: ScaleMap -> Maybe Pitch.Key -> Either DeriveT.PitchError 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)

make_keys :: [Text] -> [(Text, [(Tuning, Ratios)])] -> Keys
make_keys :: [Text] -> [(Text, [(Text, Ratios)])] -> Keys
make_keys [Text]
degrees [(Text, [(Text, Ratios)])]
key_tuning_ratios = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Text -> Key
Pitch.Key (Text
degree forall a. Semigroup a => a -> a -> a
<> Text
"-" forall a. Semigroup a => a -> a -> a
<> Text
key),
        (Tonic -> Map Text Ratios -> Key
Key Tonic
tonic (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Ratios)]
tuning_ratios)))
    | (Text
key, [(Text, Ratios)]
tuning_ratios) <- [(Text, [(Text, Ratios)])]
key_tuning_ratios
    , (Text
degree, Tonic
tonic) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
degrees [Tonic
0..]
    ]

-- * format

make_relative_fmt :: Keys -> Key -- ^ only 'key_tonic' is used
    -> TheoryFormat.RelativeFormat TheoryFormat.Tonic
make_relative_fmt :: Keys -> Key -> RelativeFormat Tonic
make_relative_fmt Keys
keys Key
default_key = TheoryFormat.RelativeFormat
    { rel_config :: Config
rel_config = Config
TheoryFormat.default_config
    , rel_key_config :: KeyConfig Tonic
rel_key_config = TheoryFormat.KeyConfig
        { key_parse :: Maybe Key -> Either PitchError Tonic
key_parse = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Key -> Tonic
key_tonic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key.
key -> Map Key key -> Maybe Key -> Either PitchError key
Scales.get_key Key
default_key Keys
keys
        , key_default :: Tonic
key_default = Tonic
0
        }
    , rel_show_degree :: ShowDegree Tonic
rel_show_degree = ShowDegree Tonic
TheoryFormat.show_degree_diatonic
    , rel_to_absolute :: ToAbsolute Tonic
rel_to_absolute = ToAbsolute Tonic
TheoryFormat.diatonic_to_absolute
    }

-- * named intervals

default_named_intervals :: ScaleDegree.NamedIntervals
default_named_intervals :: NamedIntervals
default_named_intervals = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Text
"m2-", Integer
25 forall a. Integral a => a -> a -> Ratio a
% Integer
24) -- 71, 5-limit minor half-step
    , (Text
"m2", Integer
16 forall a. Integral a => a -> a -> Ratio a
% Integer
15) -- 112, 5-limit major half-step
    , (Text
"M2-", Integer
10 forall a. Integral a => a -> a -> Ratio a
% Integer
9) -- 182, minor whole tone
    , (Text
"M2", Integer
9 forall a. Integral a => a -> a -> Ratio a
% Integer
8) -- 204, 5-limit major second
    , (Text
"m3", Integer
6 forall a. Integral a => a -> a -> Ratio a
% Integer
5) -- 316, 5-limit minor third
    , (Text
"M3", Integer
5 forall a. Integral a => a -> a -> Ratio a
% Integer
4) -- 386, 5-limit major third
    , (Text
"P4", Integer
4 forall a. Integral a => a -> a -> Ratio a
% Integer
3) -- 498, perfect fourth
    , (Text
"tt11", Integer
11 forall a. Integral a => a -> a -> Ratio a
% Integer
8) -- 551, undecimal tritone
    , (Text
"tt7-", Integer
7 forall a. Integral a => a -> a -> Ratio a
% Integer
5) -- 583, septimal tritone
    , (Text
"tt", Integer
45 forall a. Integral a => a -> a -> Ratio a
% Integer
32) -- 590, high 5-limit tritone
    , (Text
"tt7+", Integer
10 forall a. Integral a => a -> a -> Ratio a
% Integer
7) -- 618, septimal tritone
    , (Text
"wolf", Integer
40 forall a. Integral a => a -> a -> Ratio a
% Integer
27) -- 681, wolf 5-limit 5th
    , (Text
"P5", Integer
3 forall a. Integral a => a -> a -> Ratio a
% Integer
2) -- 702, perfect fifth
    , (Text
"m6", Integer
8 forall a. Integral a => a -> a -> Ratio a
% Integer
5) -- 5-limit minor sixth
    , (Text
"M6", Integer
5 forall a. Integral a => a -> a -> Ratio a
% Integer
3) -- 5-limit major sixth
    , (Text
"m7", Integer
9 forall a. Integral a => a -> a -> Ratio a
% Integer
5) -- 5-limit large minor seventh
    , (Text
"M7", Integer
15 forall a. Integral a => a -> a -> Ratio a
% Integer
8) -- 5-limit major seventh
    ]


{- Retuning scales:

    build :: Ratios -> Pitch.Degree -> Pitch.Degree -> Pitch.Hz -> [Pitch.Hz]
    build ratios per_oct degree base =
        List.sort $ map calc (zip [degree..] (Vector.toList ratios))
        where
        calc (d, rat)
            | d >= per_oct = f / 2
            | otherwise = f
            where f = base * realToFrac rat

    interpolated ratios per_oct degree from_base to_base frac =
        where
        v1 = build ratios per_oct degree from_base
        v2 = build ratios per_oct degree to_base

             A       B       C       D       E       F       G       A
    A440     440     495     550     586.6   660     773.3   825     880
    C550     458.3   515.625 550     618.75  687.5   733.3   825     916.6
    A458.3   458.3   515.587 527.875 611.06  687.45  763.83  859.312 970.6

    So if I'm going A->C I can't go through B.  I have to figure out the
    frequencies for C550 and then interpolate to those.

    The tuning pitch must be [(C, A, 0.5)].  So it starts A440, then has C.
    C maps to ratio scale of 5:4, so we set
    (-base = 440, -from = 'a', -to = 550, %-frac = %)
    (-base = 550, -from = 'c', -to = 458.3, %-frac = %)

    What I really need is base_from and base_to, where base is always A.  So
    if the tuning pitch says C then I have to figure out the A of C, based on
    the previous frequency.  I think I can do this if

    But how could this work if pitches are moving up and down?

    f0 = build major_ratios 7
    b1 = f0 0 440
    b2 = f0 2 550
    b3 = f0 0 (458 + 1/3)
-}