-- 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.Unboxed as Unboxed

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 = (Scale -> Definition) -> [Scale] -> [Definition]
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 (Scale -> Scale) -> Scale -> Scale
forall a b. (a -> b) -> a -> b
$
    ScaleId -> ScaleMap -> Doc -> Scale
ChromaticScales.make_scale ScaleId
scale_id ScaleMap
absolute_scale_map (Doc -> Scale) -> Doc -> Scale
forall a b. (a -> b) -> a -> b
$
        Doc
"The world-famous equal tempered twelve note scale.\n"
        Doc -> Doc -> Doc
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 (RelativeFormat Key -> Format
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 :: ParseKey Key
key_parse = Key -> Keys -> ParseKey Key
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 = Key -> Keys -> Maybe Key -> Maybe 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 = Key -> Keys -> Maybe 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 = (PitchError -> Maybe Note)
-> (Note -> Maybe Note) -> Either PitchError Note -> Maybe Note
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Note -> PitchError -> Maybe Note
forall a b. a -> b -> a
const Maybe Note
forall a. Maybe a
Nothing) Note -> Maybe Note
forall a. a -> Maybe a
Just
    (Either PitchError Note -> Maybe Note)
-> (Pitch -> Either PitchError Note) -> Pitch -> Maybe Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScaleMap -> Maybe Key -> Pitch -> Either PitchError Note
ChromaticScales.show_pitch ScaleMap
absolute_scale_map Maybe Key
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 (Pitch -> Maybe Note)
-> (NoteNumber -> Pitch) -> NoteNumber -> Maybe Note
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Layout -> Semi -> Pitch
Theory.semis_to_pitch_sharps Layout
layout
    (Semi -> Pitch) -> (NoteNumber -> Semi) -> NoteNumber -> Pitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Semi -> Semi
Theory.nn_to_semis (Semi -> Semi) -> (NoteNumber -> Semi) -> NoteNumber -> Semi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteNumber -> Semi
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 = (PitchError -> Maybe Pitch)
-> (Pitch -> Maybe Pitch) -> Either PitchError Pitch -> Maybe Pitch
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Pitch -> PitchError -> Maybe Pitch
forall a b. a -> b -> a
const Maybe Pitch
forall a. Maybe a
Nothing) Pitch -> Maybe Pitch
forall a. a -> Maybe a
Just
    (Either PitchError Pitch -> Maybe Pitch)
-> (Note -> Either PitchError Pitch) -> Note -> Maybe Pitch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScaleMap -> Maybe Key -> Note -> Either PitchError Pitch
ChromaticScales.read_pitch ScaleMap
absolute_scale_map Maybe Key
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 (Note -> Maybe Note -> Note
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 ([Key] -> Keys) -> [Key] -> Keys
forall a b. (a -> b) -> a -> b
$
    [Key]
church_keys [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
++ [Key]
octatonic_keys [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
++ [Key]
whole_keys [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
++ [Key]
exotic_keys

church_keys :: [Theory.Key]
church_keys :: [Key]
church_keys = [[Key]] -> [Key]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Text -> [Semi] -> [Key]) -> [Text] -> [[Semi]] -> [[Key]]
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 = [Semi -> [Semi] -> [Semi]
forall a. Semi -> [a] -> [a]
take Semi
7 (Semi -> [Semi] -> [Semi]
forall a. Semi -> [a] -> [a]
drop Semi
n [Semi]
major) | Semi
n <- [Semi
0..Semi
6]]
    major :: [Semi]
major = [Semi] -> [Semi]
forall a. [a] -> [a]
cycle ([Semi] -> [Semi]) -> [Semi] -> [Semi]
forall a b. (a -> b) -> a -> b
$ Vector Semi -> [Semi]
forall a. Unbox a => Vector a -> [a]
Unboxed.toList (Layout -> Vector Semi
Theory.layout_intervals Layout
layout)

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