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

-- | A version of a just intonation diatonic scale that is tuned based on
-- a pitch signal.
module Derive.Scale.Just where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Vector as Vector

import qualified Util.Doc as Doc
import qualified Util.Num as Num
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Env as Env
import qualified Derive.Scale as Scale
import qualified Derive.Scale.ChromaticScales as ChromaticScales
import qualified Derive.Scale.JustScales as JustScales
import qualified Derive.Scale.Raga as Raga
import qualified Derive.Scale.Scales as Scales
import qualified Derive.Scale.Theory as Theory
import qualified Derive.Scale.TheoryFormat as TheoryFormat
import qualified Derive.ShowVal as ShowVal

import qualified Perform.Pitch as Pitch

import           Global


scales :: [Scale.Definition]
scales :: [Definition]
scales = [Definition]
simple_scales forall a. [a] -> [a] -> [a]
++ [Definition]
make_scales

simple_scales :: [Scale.Definition]
simple_scales :: [Definition]
simple_scales = forall a b. (a -> b) -> [a] -> [b]
map Scale -> Definition
Scale.Simple
    [ Doc -> Scale -> Scale
Scales.add_doc Doc
"7-note just scale." forall a b. (a -> b) -> a -> b
$
        ScaleId -> ScaleMap -> Doc -> [(Doc, Doc)] -> Scale
JustScales.make_scale ScaleId
"just" (Format -> ScaleMap
scale_map Format
TheoryFormat.absolute_c)
            Doc
just_doc [(Doc, Doc)]
doc_fields
    , Doc -> Scale -> Scale
Scales.add_doc Doc
"7-note just scale." forall a b. (a -> b) -> a -> b
$
        ScaleId -> ScaleMap -> Doc -> [(Doc, Doc)] -> Scale
JustScales.make_scale ScaleId
"just-r"
            (Format -> ScaleMap
scale_map (forall key. RelativeFormat key -> Format
TheoryFormat.sargam RelativeFormat Int
relative_fmt)) Doc
just_doc [(Doc, Doc)]
doc_fields
    ]
    where
    relative_fmt :: RelativeFormat Int
relative_fmt = Keys -> Key -> RelativeFormat Int
JustScales.make_relative_fmt Keys
keys Key
default_key

make_scales :: [Scale.Definition]
make_scales :: [Definition]
make_scales =
    [ ScaleId -> Format -> Definition
scale_make_just ScaleId
"make-just7" Format
TheoryFormat.absolute_c
    , ScaleId -> Format -> Definition
scale_make_just ScaleId
"make-just7-r" (forall key. RelativeFormat key -> Format
TheoryFormat.sargam RelativeFormat Int
relative_fmt)
    ]
    where
    relative_fmt :: RelativeFormat Int
relative_fmt = Keys -> Key -> RelativeFormat Int
JustScales.make_relative_fmt forall a. Monoid a => a
mempty Key
default_key
    default_key :: Key
default_key = JustScales.Key
        { key_tonic :: Int
key_tonic = Int
0
        , key_ratios :: Map Key Ratios
key_ratios = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList []
        }

just_doc :: Doc.Doc
just_doc :: Doc
just_doc =
    Doc
"7-note scales in just intonation.\
    \\nThey are fundamentally 7 note scales because they use a A-G or SRGMPDN.\
    \ While they support sharps and flats and have a piano-style layout,\
    \ accidentals are implemented as simple ratio offsets from base pitch.\
    \ Extending to more flexible notions of just intonation would require\
    \ generalizing the input mapping and pitch notation.\
    \\nKeys look like `c-maj`, where `c` is the tonic and `maj` selects\
    \ the ratios to use. For absolute notation, the tonic determines where\
    \ the scale starts, while for relative notation, the tonic determines\
    \ only which MIDI key maps to the first scale degree. So for the ASCII kbd\
    \ where the input is also relative, the tonic is irrelevant."

doc_fields :: [(Doc.Doc, Doc.Doc)]
doc_fields :: [(Doc, Doc)]
doc_fields =
    [ (Key -> Doc
Doc.literal Key
name,
        Key -> Doc
Doc.Doc forall a b. (a -> b) -> a -> b
$ Map Key Ratios -> Key
JustScales.show_ratios (Key -> Map Key Ratios
JustScales.key_ratios Key
key))
    | (Key
name, Key
key) <- forall a. [(Key, a)] -> [(Key, a)]
ChromaticScales.group_tonic_mode (forall k a. Map k a -> [(k, a)]
Map.toList Keys
keys)
    ]

scale_map :: TheoryFormat.Format -> JustScales.ScaleMap
scale_map :: Format -> ScaleMap
scale_map = Keys -> Key -> Maybe Key -> Format -> ScaleMap
JustScales.scale_map Keys
keys Key
default_key (forall a. a -> Maybe a
Just Key
default_tuning)

default_key :: JustScales.Key
Just Key
default_key = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Key -> Key
Pitch.Key Key
"c-maj") Keys
keys

keys :: Map Pitch.Key JustScales.Key
keys :: Keys
keys = [Key] -> [(Key, [(Key, Ratios)])] -> Keys
JustScales.make_keys [Key]
TheoryFormat.absolute_c_degrees [(Key, [(Key, Ratios)])]
key_ratios

key_ratios :: [(Text, [(JustScales.Tuning, JustScales.Ratios)])]
key_ratios :: [(Key, [(Key, Ratios)])]
key_ratios =
    [ (Key
name, forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. [Int] -> Vector a -> Vector a
select [Int]
is)) (forall k a. Map k a -> [(k, a)]
Map.toList Map Key Ratios
tunings))
    | (Key
name, [Int]
is) <- [(Key, [Int])]
named_intervals
    ]

named_intervals :: [(Text, [Pitch.Semi])]
named_intervals :: [(Key, [Int])]
named_intervals = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. Int -> [a] -> [a]
take Int
7)) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Key]
names forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]]
List.tails forall a b. (a -> b) -> a -> b
$
    forall a. [a] -> [a]
cycle [Int]
Theory.piano_intervals
    where
    -- The names are the same as in Twelve.
    names :: [Key]
names = [Key
"maj", Key
"dorian", Key
"phrygian", Key
"lydian", Key
"mixolydian", Key
"min",
        Key
"locrian"]

select :: [Int] -> Vector.Vector a -> Vector.Vector a
select :: forall a. [Int] -> Vector a -> Vector a
select [Int]
intervals Vector a
v =
    forall b a. Int -> (b -> Maybe (a, b)) -> b -> Vector a
Vector.unfoldrN (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
intervals) [Int] -> Maybe (a, [Int])
make (forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall a. Num a => a -> a -> a
(+) Int
0 [Int]
intervals)
    where
    make :: [Int] -> Maybe (a, [Int])
make (Int
i:[Int]
is) = forall a. a -> Maybe a
Just (Vector a
v forall a. Vector a -> Int -> a
Vector.! Int
i, [Int]
is)
    make [] = forall a. Maybe a
Nothing

tunings :: Map JustScales.Tuning JustScales.Ratios
tunings :: Map Key Ratios
tunings = 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]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a. [a] -> Vector a
Vector.fromList)
    -- 5-limit would be more natural than limit-5, but I'd need quotes then.
    [ (Key
"limit-5",
        [Ratio Int
1, Ratio Int
16forall a. Fractional a => a -> a -> a
/Ratio Int
15, Ratio Int
9forall a. Fractional a => a -> a -> a
/Ratio Int
8, Ratio Int
6forall a. Fractional a => a -> a -> a
/Ratio Int
5, Ratio Int
5forall a. Fractional a => a -> a -> a
/Ratio Int
4, Ratio Int
4forall a. Fractional a => a -> a -> a
/Ratio Int
3, Ratio Int
45forall a. Fractional a => a -> a -> a
/Ratio Int
32, Ratio Int
3forall a. Fractional a => a -> a -> a
/Ratio Int
2, Ratio Int
8forall a. Fractional a => a -> a -> a
/Ratio Int
5, Ratio Int
5forall a. Fractional a => a -> a -> a
/Ratio Int
3, Ratio Int
9forall a. Fractional a => a -> a -> a
/Ratio Int
5, Ratio Int
15forall a. Fractional a => a -> a -> a
/Ratio Int
8])
    , (Key
"limit-7",
        [Ratio Int
1, Ratio Int
15forall a. Fractional a => a -> a -> a
/Ratio Int
14, Ratio Int
8forall a. Fractional a => a -> a -> a
/Ratio Int
7, Ratio Int
6forall a. Fractional a => a -> a -> a
/Ratio Int
5, Ratio Int
5forall a. Fractional a => a -> a -> a
/Ratio Int
4, Ratio Int
4forall a. Fractional a => a -> a -> a
/Ratio Int
3, Ratio Int
7forall a. Fractional a => a -> a -> a
/Ratio Int
5, Ratio Int
3forall a. Fractional a => a -> a -> a
/Ratio Int
2, Ratio Int
8forall a. Fractional a => a -> a -> a
/Ratio Int
5, Ratio Int
5forall a. Fractional a => a -> a -> a
/Ratio Int
3, Ratio Int
7forall a. Fractional a => a -> a -> a
/Ratio Int
4, Ratio Int
15forall a. Fractional a => a -> a -> a
/Ratio Int
8])
    ]
    -- 11+ limit adds intervals which get increasingly far from the 7 note
    -- framework, so I'd need some other way to name them.

default_tuning :: JustScales.Tuning
default_tuning :: Key
default_tuning = Key
"limit-5"

{-
    c   db     d    eb   e    f    f#     g    ab   a    bb   b
    [1, 16/15, 9/8, 6/5, 5/4, 4/3, 45/32, 3/2, 8/5, 5/3, 9/5, 15/8]

    Ptolemy's intense diatonic scale.
    I, IV, and V are in-tune major triads of 4:5:6.
    But ii and vii dim not very ideal.
    [1,        9/8,      5/4, 4/3,        3/2,      5/3,      15/8]

    i, iv, and v are in-tune minor triads of 10:12:15.
    But ii dim and VII are out.
    [1,        9/8, 6/5,      4/3,        3/2, 8/5,      9/5]
-}


-- * make just

-- | Make a 7 note just scale with custom ratios or intervals.
scale_make_just :: Pitch.ScaleId -> TheoryFormat.Format -> Scale.Definition
scale_make_just :: ScaleId -> Format -> Definition
scale_make_just ScaleId
scale_id Format
fmt =
    ScaleId
-> (Key, DocumentedCall)
-> (Environ -> LookupScale -> Either PitchError Scale)
-> Definition
Scale.Make ScaleId
scale_id (Format -> Key
TheoryFormat.fmt_pattern Format
fmt, DocumentedCall
call_doc)
        (ScaleId
-> Format -> Environ -> LookupScale -> Either PitchError Scale
make_just ScaleId
scale_id Format
fmt)
    where
    call_doc :: DocumentedCall
call_doc = Set Control
-> Doc -> [(Doc, Doc)] -> DocumentedCall -> DocumentedCall
Scales.annotate_call_doc Set Control
Scales.standard_transposers
        Doc
doc [] DocumentedCall
JustScales.default_call_doc
    doc :: Doc
doc = Doc
"Set " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Key
just_ratios forall a. Semigroup a => a -> a -> a
<> Doc
" to make a custom scale, and "
        forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Key
just_intervals forall a. Semigroup a => a -> a -> a
<> Doc
" to select from it. The intervals\
        \ default to replicate 7 1, and the number of ratios should be\
        \ sum intervals - 1 (the initial 1/1 is implicit).\
        \ Ratios can be a list, or one of " forall a. Semigroup a => a -> a -> a
<> [Key] -> Doc
literals (forall k a. Map k a -> [k]
Map.keys Map Key Ratios
tunings)
        forall a. Semigroup a => a -> a -> a
<> Doc
", and intervals can be a list or one of "
        forall a. Semigroup a => a -> a -> a
<> [Key] -> Doc
literals (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Key, [Int])]
named_intervals
            forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Key, [Int])]
Raga.melakarta_intervals)
        forall a. Semigroup a => a -> a -> a
<> Doc
"\n\n" forall a. Semigroup a => a -> a -> a
<> Doc
just_doc
    literals :: [Key] -> Doc
literals = [Doc] -> Doc
Doc.commas forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Key -> Doc
Doc.literal

all_named_intervals :: Map Text [Pitch.Semi]
all_named_intervals :: Map Key [Int]
all_named_intervals = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ [(Key, [Int])]
named_intervals forall a. [a] -> [a] -> [a]
++ [(Key, [Int])]
Raga.melakarta_intervals

just_ratios :: Env.Key
just_ratios :: Key
just_ratios = Key
"just-ratios"

just_intervals :: Env.Key
just_intervals :: Key
just_intervals = Key
"just-intervals"

make_just :: Pitch.ScaleId -> TheoryFormat.Format
    -> Env.Environ -> Scale.LookupScale
    -> Either DeriveT.PitchError Scale.Scale
make_just :: ScaleId
-> Format -> Environ -> LookupScale -> Either PitchError Scale
make_just ScaleId
scale_id Format
fmt Environ
env LookupScale
_ = do
    [Int]
intervals <- Environ -> Either PitchError [Int]
parse_intervals Environ
env
    Ratios
ratios <- [Int] -> Environ -> Either PitchError Ratios
parse_ratios [Int]
intervals Environ
env
    let default_key :: Key
default_key = JustScales.Key
            { key_tonic :: Int
key_tonic = Int
0
            , key_ratios :: Map Key Ratios
key_ratios = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Key
"", Ratios
ratios)]
            }
    let smap :: ScaleMap
smap = Keys -> Key -> Maybe Key -> Format -> ScaleMap
JustScales.scale_map forall k a. Map k a
Map.empty Key
default_key forall a. Maybe a
Nothing Format
fmt
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ScaleId -> ScaleMap -> Doc -> [(Doc, Doc)] -> Scale
JustScales.make_scale ScaleId
scale_id ScaleMap
smap Doc
"unused doc" []

parse_intervals :: Env.Environ -> Either DeriveT.PitchError [Pitch.Semi]
parse_intervals :: Environ -> Either PitchError [Int]
parse_intervals =
    forall a val.
(Typecheck a, ShowVal a) =>
(a -> Either (Maybe Key) val)
-> Maybe (Either PitchError val)
-> Key
-> Environ
-> Either PitchError val
Scales.read_environ_ Either [Int] Key -> Either (Maybe Key) [Int]
parse (forall a. a -> Maybe a
Just (forall a b. b -> Either a b
Right (forall a. Int -> a -> [a]
replicate Int
7 Int
1))) Key
just_intervals
    where
    parse :: Either [Int] Key -> Either (Maybe Key) [Int]
parse (Left [Int]
xs) = forall a b. b -> Either a b
Right [Int]
xs
    parse (Right Key
sym) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Key
"not one of: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Key
pretty (forall k a. Map k a -> [k]
Map.keys Map Key [Int]
all_named_intervals))
        forall a b. b -> Either a b
Right (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
sym Map Key [Int]
all_named_intervals)

parse_ratios :: [Pitch.Semi] -> Env.Environ
    -> Either DeriveT.PitchError JustScales.Ratios
parse_ratios :: [Int] -> Environ -> Either PitchError Ratios
parse_ratios [Int]
intervals = forall a val.
(Typecheck a, ShowVal a) =>
(a -> Either (Maybe Key) val)
-> Maybe (Either PitchError val)
-> Key
-> Environ
-> Either PitchError val
Scales.read_environ_ Either [Ratio Int] Key -> Either (Maybe Key) Ratios
parse forall a. Maybe a
Nothing Key
just_ratios
    where
    parse :: Either [Ratio Int] Key -> Either (Maybe Key) Ratios
parse (Right Key
sym) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Key
"not one of: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Key
pretty (forall k a. Map k a -> [k]
Map.keys Map Key Ratios
tunings))
        forall {a}. Vector a -> Either (Maybe Key) (Vector a)
check (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
sym Map Key Ratios
tunings)
    parse (Left [Ratio Int]
ratios) = forall {a}. Vector a -> Either (Maybe Key) (Vector a)
check forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Vector a
Vector.fromList (Ratio Int
1forall a. a -> [a] -> [a]
:[Ratio Int]
ratios)
    check :: Vector a -> Either (Maybe Key) (Vector a)
check Vector a
ratios
        | forall a. Vector a -> Int
Vector.length Vector a
ratios forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum [Int]
intervals =
            forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. [Int] -> Vector a -> Vector a
select [Int]
intervals Vector a
ratios
        | Bool
otherwise = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            Key
"length should be sum " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Key
pretty [Int]
intervals forall a. Semigroup a => a -> a -> a
<> Key
" - 1, but was "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Key
pretty (forall a. Vector a -> Int
Vector.length Vector a
ratios forall a. Num a => a -> a -> a
- Int
1)
        -- I don't subtract 1 because I already put 1/1 on.