-- 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.Octa where
import qualified Data.Map as Map
import qualified Data.Vector as Vector

import qualified Derive.Scale as Scale
import qualified Derive.Scale.ChromaticScales as ChromaticScales
import qualified Derive.Scale.Scales as Scales
import qualified Derive.Scale.Theory as Theory
import qualified Derive.Scale.TheoryFormat as TheoryFormat

import qualified Perform.Pitch as Pitch


scales :: [Scale.Definition]
scales :: [Definition]
scales = forall a b. (a -> b) -> [a] -> [b]
map Scale -> Definition
Scale.Simple
    [ ScaleId -> Layout -> Keys -> Format -> Scale
make_scale ScaleId
"octa21" Layout
layout21 Keys
keys21 Format
absolute_fmt
    , ScaleId -> Layout -> Keys -> Format -> Scale
make_scale ScaleId
"octa12" Layout
layout12 Keys
keys12 Format
absolute_fmt
    , ScaleId -> Layout -> Keys -> Format -> Scale
make_scale ScaleId
"octa21-r" Layout
layout21 Keys
keys21 (Keys -> Format
relative_fmt Keys
keys21)
    , ScaleId -> Layout -> Keys -> Format -> Scale
make_scale ScaleId
"octa12-r" Layout
layout12 Keys
keys12 (Keys -> Format
relative_fmt Keys
keys12)
    ]
    where
    layout21 :: Layout
layout21 = [PitchClass] -> Layout
Theory.layout [PitchClass
2, PitchClass
1, PitchClass
2, PitchClass
1, PitchClass
2, PitchClass
1, PitchClass
2, PitchClass
1]
    layout12 :: Layout
layout12 = [PitchClass] -> Layout
Theory.layout [PitchClass
1, PitchClass
2, PitchClass
1, PitchClass
2, PitchClass
1, PitchClass
2, PitchClass
1, PitchClass
2]
    keys21 :: Keys
keys21 = Layout -> Keys
all_keys Layout
layout21
    keys12 :: Keys
keys12 = Layout -> Keys
all_keys Layout
layout12

absolute_fmt :: TheoryFormat.Format
absolute_fmt :: Format
absolute_fmt =
    Text -> Degrees -> Format
TheoryFormat.make_absolute_format (Degrees -> Text
TheoryFormat.make_pattern Degrees
degrees)
        Degrees
degrees
    where
    degrees :: Degrees
degrees = [Text] -> Degrees
TheoryFormat.make_degrees [Text
"a", Text
"b", Text
"c", Text
"d", Text
"e", Text
"f", Text
"g", Text
"h"]

relative_fmt :: ChromaticScales.Keys -> TheoryFormat.Format
relative_fmt :: Keys -> Format
relative_fmt Keys
keys = forall {key}. RelativeFormat key -> Format
make forall a b. (a -> b) -> a -> b
$ 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 = Maybe Key -> Either PitchError Key
parse_key
        , key_default :: Key
key_default = Key
default_theory_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
    }
    where
    parse_key :: Maybe Key -> Either PitchError Key
parse_key = forall key.
key -> Map Key key -> Maybe Key -> Either PitchError key
Scales.get_key Key
default_theory_key Keys
keys
    Just Key
default_theory_key = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
default_key Keys
keys
    make :: RelativeFormat key -> Format
make = forall key. Text -> Degrees -> RelativeFormat key -> Format
TheoryFormat.make_relative_format (Degrees -> Text
TheoryFormat.make_pattern Degrees
degrees)
        Degrees
degrees
    degrees :: Degrees
degrees = [Text] -> Degrees
TheoryFormat.make_degrees
        [Text
"一", Text
"二", Text
"三", Text
"四", Text
"五", Text
"六", Text
"七", Text
"八"]

make_scale :: Pitch.ScaleId -> Theory.Layout -> ChromaticScales.Keys
    -> TheoryFormat.Format -> Scale.Scale
make_scale :: ScaleId -> Layout -> Keys -> Format -> Scale
make_scale ScaleId
scale_id Layout
layout Keys
keys Format
fmt =
    ScaleId -> ScaleMap -> Doc -> Scale
ChromaticScales.make_scale ScaleId
scale_id ScaleMap
scale_map Doc
doc
    where
    scale_map :: ScaleMap
scale_map = Layout -> Format -> Keys -> Key -> ScaleMap
ChromaticScales.scale_map Layout
layout Format
fmt Keys
keys Key
default_theory_key
    Just Key
default_theory_key = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
default_key Keys
keys
    doc :: Doc
doc = Doc
"Octatonic scales as true 8 note scales, using notes from a-h.\
        \ There are two variants: octa21 starts with a whole step, while\
        \ octa12 starts with a half-step.\n"
        forall a. Semigroup a => a -> a -> a
<> Doc
ChromaticScales.twelve_doc

default_key :: Pitch.Key
default_key :: Key
default_key = Text -> Key
Pitch.Key Text
"a"

all_degrees :: [Pitch.Degree]
all_degrees :: [Degree]
all_degrees = [PitchClass -> PitchClass -> Degree
Pitch.Degree PitchClass
pc PitchClass
accs | PitchClass
pc <- [PitchClass
0..PitchClass
7], PitchClass
accs <- [-PitchClass
1..PitchClass
1]]

make_keys :: Theory.Layout -> [Pitch.Semi] -> [Theory.Key]
make_keys :: Layout -> [PitchClass] -> [Key]
make_keys Layout
layout [PitchClass]
intervals =
    [Degree -> Text -> [PitchClass] -> Layout -> Key
Theory.key Degree
tonic Text
"" [PitchClass]
intervals Layout
layout
        | Degree
tonic <- [Degree]
all_degrees, forall a. Num a => a -> a
abs (Degree -> PitchClass
Pitch.degree_accidentals Degree
tonic) forall a. Ord a => a -> a -> Bool
<= PitchClass
1]

all_keys :: Theory.Layout -> ChromaticScales.Keys
all_keys :: Layout -> Keys
all_keys Layout
layout =
    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
absolute_fmt) [Key]
keys) [Key]
keys
    where
    keys :: [Key]
keys = Layout -> [PitchClass] -> [Key]
make_keys Layout
layout forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> [a]
Vector.toList (Layout -> Intervals
Theory.layout_intervals Layout
layout)