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

{-# LANGUAGE CPP #-}
{- | The equal tempered 12 note scale, aka 12TET.

    For the note text, I use a non-traditional format that goes "octave note
    sharp" instead of "note sharp octave".  General to specific is more
    aesthetically appealing.

    4c is middle C, and the range is limited to the midi range.  Since
    'Pitch.NoteNumber's also use midi numbering, conversions are trivial.

    > nn 127 = 9g
    > nn 120 = 9c
    > middle c = nn 60 = 4c
    > nn 24 = 1c
    > nn 12 = 0c
    > nn 0 = -1c
-}
module Derive.Scale.Twelve (
    scales, scale_id
    -- * keys
    , lookup_key, default_key
    -- * utils
    , show_nn, read_absolute_pitch, nn_pitch

#ifdef TESTING
    , module Derive.Scale.Twelve
#endif
) where
import qualified Data.Map as Map
import qualified Data.Vector as Vector

import qualified Derive.PSignal as PSignal
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

import           Global


scales :: [Scale.Definition]
scales :: [Definition]
scales = forall a b. (a -> b) -> [a] -> [b]
map Scale -> Definition
Scale.Simple [Scale
scale, Scale
relative_scale, Scale
keyed_scale]

scale :: Scale.Scale
scale :: Scale
scale = Scale -> Scale
Scales.set_direct_input_to_nn forall a b. (a -> b) -> a -> b
$
    ScaleId -> ScaleMap -> Doc -> Scale
ChromaticScales.make_scale ScaleId
scale_id ScaleMap
absolute_scale_map forall a b. (a -> b) -> a -> b
$
        Doc
"The world-famous equal tempered twelve note scale.\n"
        forall a. Semigroup a => a -> a -> a
<> Doc
ChromaticScales.twelve_doc

relative_scale :: Scale.Scale
relative_scale :: Scale
relative_scale = ScaleId -> ScaleMap -> Doc -> Scale
ChromaticScales.make_scale ScaleId
"twelve-r" ScaleMap
relative_scale_map
    Doc
"This is 12TET, but spelled relative to the current key and mode."

keyed_scale :: Scale.Scale
keyed_scale :: Scale
keyed_scale = ScaleId -> ScaleMap -> Doc -> Scale
ChromaticScales.make_scale ScaleId
"twelve-k" ScaleMap
keyed_scale_map
    Doc
"This variant treats accidentals like staff notation. If a pitch doesn't\
    \ have an accidental, it will inherit from the key signature. It thus\
    \ needs an explicit natural to cancel that out. Unlike staff notation,\
    \ accidentals don't persist until the next barline."

scale_id :: Pitch.ScaleId
scale_id :: ScaleId
scale_id = ScaleId
"twelve"

absolute_scale_map :: ChromaticScales.ScaleMap
absolute_scale_map :: ScaleMap
absolute_scale_map =
    Layout -> Format -> Keys -> Key -> ScaleMap
ChromaticScales.scale_map Layout
layout Format
absolute_fmt Keys
all_keys Key
default_theory_key

absolute_fmt :: TheoryFormat.Format
absolute_fmt :: Format
absolute_fmt = Format
TheoryFormat.absolute_c

relative_scale_map :: ChromaticScales.ScaleMap
relative_scale_map :: ScaleMap
relative_scale_map =
    Layout -> Format -> Keys -> Key -> ScaleMap
ChromaticScales.scale_map Layout
layout (forall key. RelativeFormat key -> Format
TheoryFormat.sargam RelativeFormat Key
fmt)
        Keys
all_keys Key
default_theory_key
    where fmt :: RelativeFormat Key
fmt = Key -> Keys -> RelativeFormat Key
ChromaticScales.relative_fmt Key
default_theory_key Keys
all_keys

keyed_scale_map :: ChromaticScales.ScaleMap
keyed_scale_map :: ScaleMap
keyed_scale_map =
    Layout -> Format -> Keys -> Key -> ScaleMap
ChromaticScales.scale_map Layout
layout Format
fmt Keys
all_keys Key
default_theory_key
    where
    fmt :: Format
fmt = Config -> KeyConfig Key -> Text -> Degrees -> Format
TheoryFormat.make_absolute_format_keyed Config
config KeyConfig Key
key_config
        (Degrees -> Text
TheoryFormat.make_pattern Degrees
degrees) Degrees
degrees
    key_config :: KeyConfig Key
key_config = TheoryFormat.KeyConfig
        { key_parse :: Maybe Key -> Either PitchError Key
key_parse = forall key.
key -> Map Key key -> Maybe Key -> Either PitchError key
Scales.get_key Key
default_theory_key Keys
all_keys
        , key_default :: Key
key_default = Key
default_theory_key
        }
    degrees :: Degrees
degrees = [Text] -> Degrees
TheoryFormat.make_degrees [Text]
TheoryFormat.absolute_c_degrees
    -- I'm worried that 'n' for natural looks ugly, so let's try the symbolic
    -- accidentals.
    config :: Config
config = Config
TheoryFormat.default_config
        { config_accidental :: AccidentalFormat
TheoryFormat.config_accidental = AccidentalFormat
TheoryFormat.symbol_accidentals }

-- * keys

lookup_key :: Maybe Pitch.Key -> Maybe Theory.Key
lookup_key :: Maybe Key -> Maybe Key
lookup_key = forall key. key -> Map Key key -> Maybe Key -> Maybe key
Scales.lookup_key Key
default_theory_key Keys
all_keys

default_key :: Pitch.Key
default_key :: Key
default_key = Text -> Key
Pitch.Key Text
"c-maj"

default_theory_key :: Theory.Key
Just Key
default_theory_key = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Key
default_key Keys
all_keys

show_pitch :: Pitch.Pitch -> Maybe Pitch.Note
show_pitch :: Pitch -> Maybe Note
show_pitch = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScaleMap -> Maybe Key -> Pitch -> Either PitchError Note
ChromaticScales.show_pitch ScaleMap
absolute_scale_map forall a. Maybe a
Nothing

-- * utils

-- | Map NoteNumbers to their nearest Note.
show_nn :: Pitch.NoteNumber -> Maybe Pitch.Note
show_nn :: NoteNumber -> Maybe Note
show_nn = Pitch -> Maybe Note
show_pitch forall b c a. (b -> c) -> (a -> b) -> a -> c
. Layout -> Semi -> Pitch
Theory.semis_to_pitch_sharps Layout
layout
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Semi -> Semi
Theory.nn_to_semis forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
round

read_absolute_pitch :: Pitch.Note -> Maybe Pitch.Pitch
read_absolute_pitch :: Note -> Maybe Pitch
read_absolute_pitch = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScaleMap -> Maybe Key -> Note -> Either PitchError Pitch
ChromaticScales.read_pitch ScaleMap
absolute_scale_map forall a. Maybe a
Nothing

nn_pitch :: Pitch.NoteNumber -> PSignal.Pitch
nn_pitch :: NoteNumber -> Pitch
nn_pitch NoteNumber
nn = ScaleId -> Note -> NoteNumber -> Pitch
PSignal.constant_pitch ScaleId
scale_id (forall a. a -> Maybe a -> a
fromMaybe Note
"x" (NoteNumber -> Maybe Note
show_nn NoteNumber
nn)) NoteNumber
nn

-- * implementation

all_keys :: Map Pitch.Key Theory.Key
all_keys :: Keys
all_keys = Format -> [Key] -> Keys
ChromaticScales.make_keys Format
absolute_fmt forall a b. (a -> b) -> a -> b
$
    [Key]
church_keys forall a. [a] -> [a] -> [a]
++ [Key]
octatonic_keys forall a. [a] -> [a] -> [a]
++ [Key]
whole_keys forall a. [a] -> [a] -> [a]
++ [Key]
exotic_keys

church_keys :: [Theory.Key]
church_keys :: [Key]
church_keys = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Text -> [Semi] -> [Key]
make_keys [Text]
modes [[Semi]]
intervals)
    where
    modes :: [Text]
modes = [Text
"maj", Text
"dorian", Text
"phrygian", Text
"lydian", Text
"mixolydian", Text
"min",
        Text
"locrian"]
    intervals :: [[Semi]]
intervals = [forall a. Semi -> [a] -> [a]
take Semi
7 (forall a. Semi -> [a] -> [a]
drop Semi
n [Semi]
major) | Semi
n <- [Semi
0..Semi
6]]
    major :: [Semi]
major = forall a. [a] -> [a]
cycle forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> [a]
Vector.toList (Layout -> Intervals
Theory.layout_intervals Layout
layout)

octatonic_keys :: [Theory.Key]
octatonic_keys :: [Key]
octatonic_keys = Text -> [Semi] -> [Key]
make_keys Text
"octa21" (forall a. Semi -> [a] -> [a]
take Semi
8 (forall a. [a] -> [a]
cycle [Semi
2, Semi
1]))
    forall a. [a] -> [a] -> [a]
++ Text -> [Semi] -> [Key]
make_keys Text
"octa12" (forall a. Semi -> [a] -> [a]
take Semi
8 (forall a. [a] -> [a]
cycle [Semi
1, Semi
2]))

whole_keys :: [Theory.Key]
whole_keys :: [Key]
whole_keys = Text -> [Semi] -> [Key]
make_keys Text
"whole" (forall a. Semi -> a -> [a]
replicate Semi
6 Semi
2)

-- | Keys that are diatonic, but have nonstandard key signatures.
exotic_keys :: [Theory.Key]
exotic_keys :: [Key]
exotic_keys = Text -> [Semi] -> [Key]
make_keys Text
"hijaz" [Semi
1, Semi
3, Semi
1, Semi
2, Semi
1, Semi
2, Semi
2]

-- | The layout of keys on everyone's favorite boxed harp.
layout :: Theory.Layout
layout :: Layout
layout = Layout
Theory.piano_layout

make_keys :: Text -> [Pitch.Semi] -> [Theory.Key]
make_keys :: Text -> [Semi] -> [Key]
make_keys Text
name [Semi]
intervals =
    [Degree -> Text -> [Semi] -> Layout -> Key
Theory.key Degree
tonic Text
name [Semi]
intervals Layout
layout | Degree
tonic <- [Degree]
all_degrees]
    where
    all_degrees :: [Degree]
all_degrees = [Semi -> Semi -> Degree
Pitch.Degree Semi
pc Semi
accs | Semi
pc <- [Semi
0..Semi
6], Semi
accs <- [-Semi
1..Semi
1]]