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

-- | Equal divisions of the octave.
module Derive.Scale.Edo where
import qualified Data.Map as Map

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.Just as Just
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 Derive.Typecheck as Typecheck

import qualified Perform.Pitch as Pitch

import           Global


scales :: [Scale.Definition]
scales :: [Definition]
scales = [ScaleId -> Definition
make ScaleId
"edo"]

make :: Pitch.ScaleId -> Scale.Definition
make :: ScaleId -> Definition
make ScaleId
scale_id = ScaleId
-> (Text, DocumentedCall)
-> (Environ -> LookupScale -> Either PitchError Scale)
-> Definition
Scale.Make ScaleId
scale_id (Text
pattern, DocumentedCall
call_doc) (ScaleId -> Environ -> LookupScale -> Either PitchError Scale
make_edo ScaleId
scale_id)
    where
    pattern :: Text
pattern = Format -> Text
TheoryFormat.fmt_pattern forall a b. (a -> b) -> a -> b
$ Semi -> Format
TheoryFormat.letters Semi
25
    call_doc :: DocumentedCall
call_doc = Set Control
-> Doc -> [(Doc, Doc)] -> DocumentedCall -> DocumentedCall
Scales.annotate_call_doc Set Control
Scales.standard_transposers
        Doc
doc [] DocumentedCall
Scales.default_scale_degree_doc
    doc :: Doc
doc = Doc
"Construct a scale from equal divisions of the octave.\
        \ The number of divisions are given by " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Text
edo_divisions
        forall a. Semigroup a => a -> a -> a
<> Doc
". The intervals that correspond to diatonic notes are from "
        forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Text
edo_intervals forall a. Semigroup a => a -> a -> a
<> Doc
", which defaults to all 1s.\
        \ Because the diatonic intervals are given explicitly, there are no\
        \ keys, and because the notes per octave is variable, diatonic notes\
        \ start from A, rather than the conventional C."

make_edo :: Pitch.ScaleId -> Env.Environ -> Scale.LookupScale
    -> Either DeriveT.PitchError Scale.Scale
make_edo :: ScaleId -> Environ -> LookupScale -> Either PitchError Scale
make_edo ScaleId
scale_id Environ
env LookupScale
_ = do
    Semi
divisions <- Environ -> Either PitchError Semi
parse_divisions Environ
env
    [Semi]
intervals <- Semi -> Environ -> Either PitchError [Semi]
parse_intervals Semi
divisions Environ
env
    let layout :: Layout
layout = [Semi] -> Layout
Theory.layout [Semi]
intervals
    let fmt :: Format
fmt = Semi -> Format
TheoryFormat.letters (Layout -> Semi
Theory.layout_pc_per_octave Layout
layout)
    let default_key :: Key
default_key = Degree -> Text -> [Semi] -> Layout -> Key
Theory.key (Semi -> Semi -> Degree
Pitch.Degree Semi
0 Semi
0) Text
"" [Semi]
intervals Layout
layout
    let smap :: ScaleMap
smap = (Layout -> Format -> Keys -> Key -> ScaleMap
ChromaticScales.scale_map Layout
layout Format
fmt forall a. Monoid a => a
mempty Key
default_key)
            { smap_semis_to_nn :: SemisToNoteNumber
ChromaticScales.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
. Semi -> Double -> NoteNumber
semis_to_nn Semi
divisions
            }
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ScaleId -> ScaleMap -> Doc -> Scale
ChromaticScales.make_scale ScaleId
scale_id ScaleMap
smap Doc
"unused doc"

semis_to_nn :: Int -> Pitch.FSemi -> Pitch.NoteNumber
semis_to_nn :: Semi -> Double -> NoteNumber
semis_to_nn Semi
divisions = Double -> NoteNumber
Pitch.NoteNumber forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+Double
12) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
*Double
step)
    where step :: Double
step = Double
12 forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Semi
divisions

edo_divisions :: Env.Key
edo_divisions :: Text
edo_divisions = Text
"edo-divisions"

edo_intervals :: Env.Key
edo_intervals :: Text
edo_intervals = Text
"edo-intervals"

parse_divisions :: Env.Environ -> Either DeriveT.PitchError Int
parse_divisions :: Environ -> Either PitchError Semi
parse_divisions =
    forall a val.
(Typecheck a, ShowVal a) =>
(a -> Maybe val)
-> Maybe val -> Text -> Environ -> Either PitchError val
Scales.read_environ (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Positive a -> a
Typecheck.positive) forall a. Maybe a
Nothing Text
edo_divisions

parse_intervals :: Int -> Env.Environ -> Either DeriveT.PitchError [Pitch.Semi]
parse_intervals :: Semi -> Environ -> Either PitchError [Semi]
parse_intervals Semi
divisions =
    forall a val.
(Typecheck a, ShowVal a) =>
(a -> Either (Maybe Text) val)
-> Maybe (Either PitchError val)
-> Text
-> Environ
-> Either PitchError val
Scales.read_environ_ (forall {t :: * -> *}.
(Foldable t, Pretty (t Semi)) =>
t Semi -> Either (Maybe Text) (t Semi)
check forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Either [Semi] Text -> Either (Maybe Text) [Semi]
parse)
        (forall a. a -> Maybe a
Just (forall a b. b -> Either a b
Right (forall a. Semi -> a -> [a]
replicate Semi
divisions Semi
1))) Text
edo_intervals
    where
    parse :: Either [Semi] Text -> Either (Maybe Text) [Semi]
parse (Left [Semi]
xs) = forall a b. b -> Either a b
Right [Semi]
xs
    parse (Right Text
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
$ Text
"not one of: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall k a. Map k a -> [k]
Map.keys Map Text [Semi]
named_intervals))
        forall a b. b -> Either a b
Right (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
sym Map Text [Semi]
named_intervals)
    check :: t Semi -> Either (Maybe Text) (t Semi)
check t Semi
intervals
        | forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum t Semi
intervals forall a. Eq a => a -> a -> Bool
== Semi
divisions = forall a b. b -> Either a b
Right t Semi
intervals
        | 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
$ Text
"sum " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty t Semi
intervals
            forall a. Semigroup a => a -> a -> a
<> Text
" should equal divisions " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Semi
divisions

named_intervals :: Map Text [Pitch.Semi]
named_intervals :: Map Text [Semi]
named_intervals = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, [Semi])]
Just.named_intervals