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

-- | Scales invented by Wendy Carlos.  Derived from
-- <http://www.wendycarlos.com/resources/pitch.html>
module Derive.Scale.WendyCarlos (scales) where
import qualified Data.Attoparsec.Text as Attoparsec.Text
import qualified Data.Char as Char
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Vector as Vector

import qualified Util.ParseText as ParseText
import qualified Util.Lists as Lists
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.PSignal as PSignal
import qualified Derive.Scale as Scale
import qualified Derive.Scale.Scales as Scales
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal

import qualified Perform.Pitch as Pitch

import           Global


-- TODO letters might be hard to use with so many of them.  Maybe I should use
-- numbers?
scales :: [Scale.Definition]
scales :: [Definition]
scales = forall a b. (a -> b) -> [a] -> [b]
map Scale -> Definition
Scale.Simple
    [ ScaleId -> PitchClass -> NoteNumber -> Scale
make ScaleId
"alpha" PitchClass
19 NoteNumber
78
    , ScaleId -> PitchClass -> NoteNumber -> Scale
make ScaleId
"beta" PitchClass
19 NoteNumber
63.8
    , ScaleId -> PitchClass -> NoteNumber -> Scale
make ScaleId
"gamma" PitchClass
35 NoteNumber
35.1
    ]
    where
    make :: ScaleId -> PitchClass -> NoteNumber -> Scale
make ScaleId
scale_id PitchClass
per_octave NoteNumber
cents =
        ScaleId -> Degrees -> Scale
make_scale ScaleId
scale_id forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Vector a
Vector.fromList forall a b. (a -> b) -> a -> b
$ forall a. PitchClass -> [a] -> [a]
take PitchClass
per_octave forall a b. (a -> b) -> a -> b
$
            forall a. Num a => a -> a -> [a]
Lists.range_ NoteNumber
0 (NoteNumber
centsforall a. Fractional a => a -> a -> a
/NoteNumber
100)

type Degrees = Vector.Vector Pitch.NoteNumber

-- | Frequency for a0.
a0_nn :: ScoreT.Control
a0_nn :: Control
a0_nn = Control
"a0-nn"

make_scale :: Pitch.ScaleId -> Degrees -> Scale.Scale
make_scale :: ScaleId -> Degrees -> Scale
make_scale ScaleId
scale_id Degrees
degrees = Scale.Scale
    { scale_id :: ScaleId
scale_id = ScaleId
scale_id
    , scale_pattern :: Text
scale_pattern = Text
"[0-9][a-" forall a. Semigroup a => a -> a -> a
<> PitchClass -> Text
show_degree (PitchClass
per_octave forall a. Num a => a -> a -> a
- PitchClass
1) forall a. Semigroup a => a -> a -> a
<> Text
"]"
    , scale_symbols :: [Symbol]
scale_symbols = []
    , scale_transposers :: Set Control
scale_transposers = Set Control
transposers
    , scale_read :: Environ -> Note -> Either PitchError Pitch
scale_read = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ PitchClass -> Note -> Either PitchError Pitch
read_pitch PitchClass
per_octave
    , scale_show :: Environ -> Pitch -> Either PitchError Note
scale_show = forall a b. a -> b -> a
const (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pitch -> Note
show_pitch)
    , scale_bottom :: Pitch
scale_bottom = forall pc. Enum pc => PitchClass -> pc -> Pitch
Pitch.pitch PitchClass
0 Integer
0
    , scale_layout :: Layout
scale_layout = PitchClass -> Layout
Scale.diatonic_layout PitchClass
per_octave
    , scale_transpose :: Transpose
scale_transpose = PitchClass -> Transpose
transpose PitchClass
per_octave
    , scale_enharmonics :: Enharmonics
scale_enharmonics = Enharmonics
Scales.no_enharmonics
    , scale_note_to_call :: Note -> Maybe ValCall
scale_note_to_call = Note -> Maybe ValCall
note_to_call_
    , scale_input_to_note :: Environ -> Input -> Either PitchError Note
scale_input_to_note = PitchClass -> Environ -> Input -> Either PitchError Note
input_to_note PitchClass
per_octave
    , scale_input_to_nn :: ScoreTime -> Input -> Deriver (Either PitchError NoteNumber)
scale_input_to_nn =
        (Environ -> Input -> Either PitchError Note)
-> (Note -> Maybe ValCall)
-> ScoreTime
-> Input
-> Deriver (Either PitchError NoteNumber)
Scales.computed_input_to_nn (PitchClass -> Environ -> Input -> Either PitchError Note
input_to_note PitchClass
per_octave) Note -> Maybe ValCall
note_to_call_
    , scale_call_doc :: DocumentedCall
scale_call_doc = Set Control
-> Doc -> [(Doc, Doc)] -> DocumentedCall -> DocumentedCall
Scales.annotate_call_doc Set Control
transposers
        Doc
doc [] DocumentedCall
Scales.default_scale_degree_doc
    }
    where
    transposers :: Set Control
transposers = Set Control
Scales.standard_transposers
    per_octave :: PitchClass
per_octave = forall a. Vector a -> PitchClass
Vector.length Degrees
degrees
    note_to_call_ :: Note -> Maybe ValCall
note_to_call_ = Scale -> Degrees -> Note -> Maybe ValCall
note_to_call Scale
scale Degrees
degrees
    scale :: Scale
scale = ScaleId -> Set Control -> Scale
PSignal.Scale ScaleId
scale_id Set Control
transposers
    doc :: Doc
doc = Doc
"This is a family of scales invented by Wendy Carlos. They don't\
        \ repeat at the octave, so they support diatonic transposition only\
        \ within a single octave.\
        \\nSince diatonic transposition won't get you up an octave,\
        \ the " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Control
Controls.octave forall a. Semigroup a => a -> a -> a
<> Doc
" control will transpose\
        \ by octaves.\
        \\nThe " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Control
a0_nn forall a. Semigroup a => a -> a -> a
<> Doc
" control sets the NoteNumber of\
        \ `a0`. If it's not set, it defaults to 0, which is `c-1`."

read_pitch :: Pitch.PitchClass -> Pitch.Note
    -> Either DeriveT.PitchError Pitch.Pitch
read_pitch :: PitchClass -> Note -> Either PitchError Pitch
read_pitch PitchClass
per_octave Note
note = forall err a. err -> Maybe a -> Either err a
justErr (Note -> PitchError
DeriveT.UnparseableNote Note
note) forall a b. (a -> b) -> a -> b
$
    forall a. Parser a -> Text -> Maybe a
ParseText.maybe_parse (forall pc. Enum pc => PitchClass -> pc -> Pitch
Pitch.pitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PitchClass
ParseText.p_int forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser PitchClass
p_degree)
        (Note -> Text
Pitch.note_text Note
note)
    where
    p_degree :: Parser PitchClass
p_degree = do
        Char
c <- Parser Char
Attoparsec.Text.anyChar
        let pc :: PitchClass
pc = Char -> PitchClass
Char.ord Char
c forall a. Num a => a -> a -> a
- Char -> PitchClass
Char.ord Char
'a'
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard (PitchClass
pc forall a. Ord a => a -> a -> Bool
< PitchClass
per_octave)
        forall (m :: * -> *) a. Monad m => a -> m a
return PitchClass
pc

show_pitch :: Pitch.Pitch -> Pitch.Note
show_pitch :: Pitch -> Note
show_pitch (Pitch.Pitch PitchClass
oct (Pitch.Degree PitchClass
pc PitchClass
_)) =
    Text -> Note
Pitch.Note forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Text
showt PitchClass
oct forall a. Semigroup a => a -> a -> a
<> PitchClass -> Text
show_degree PitchClass
pc

show_degree :: Pitch.PitchClass -> Text
show_degree :: PitchClass -> Text
show_degree PitchClass
pc = Char -> Text
Text.singleton forall a b. (a -> b) -> a -> b
$ PitchClass -> Char
Char.chr forall a b. (a -> b) -> a -> b
$
    if PitchClass
pc forall a. Ord a => a -> a -> Bool
< PitchClass
26 then Char -> PitchClass
Char.ord Char
'a' forall a. Num a => a -> a -> a
+ PitchClass
pc else Char -> PitchClass
Char.ord Char
'A' forall a. Num a => a -> a -> a
+ (PitchClass
pc forall a. Num a => a -> a -> a
- PitchClass
26)

transpose :: Pitch.PitchClass -> Derive.Transpose
transpose :: PitchClass -> Transpose
transpose PitchClass
per_octave Transposition
_transposition Environ
_key PitchClass
steps Pitch
pitch
    | Pitch -> PitchClass
Pitch.pitch_pc Pitch
pitch forall a. Num a => a -> a -> a
+ PitchClass
steps forall a. Ord a => a -> a -> Bool
>= PitchClass
per_octave =
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ OutOfRange -> PitchError
DeriveT.OutOfRangeError OutOfRange
DeriveT.out_of_range
    | Bool
otherwise = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ PitchClass -> PitchClass -> Pitch -> Pitch
Pitch.add_pc PitchClass
per_octave PitchClass
steps Pitch
pitch

note_to_call :: PSignal.Scale -> Degrees -> Pitch.Note
    -> Maybe Derive.ValCall
note_to_call :: Scale -> Degrees -> Note -> Maybe ValCall
note_to_call Scale
scale Degrees
degrees Note
note = do
    Pitch
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 a b. (a -> b) -> a -> b
$ PitchClass -> Note -> Either PitchError Pitch
read_pitch PitchClass
per_octave Note
note
    -- Pass 0 for per_octave, since I'll be handling the octave here.
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PitchClass
-> Maybe PitchClass
-> Scale
-> SemisToNoteNumber
-> (PitchClass -> Maybe Note)
-> ValCall
Scales.note_to_call PitchClass
0 (forall a. a -> Maybe a
Just PitchClass
max_semi) Scale
scale
        (Pitch -> SemisToNoteNumber
semis_to_nn Pitch
pitch) (Pitch -> PitchClass -> Maybe Note
semis_to_note Pitch
pitch)
    where
    max_semi :: PitchClass
max_semi = forall a. Vector a -> PitchClass
Vector.length Degrees
degrees
    semis_to_nn :: Pitch -> SemisToNoteNumber
semis_to_nn Pitch
pitch PitchConfig
config PitchClass
semis =
        forall err a. err -> Maybe a -> Either err a
justErr (forall a. Real a => a -> (PitchClass, PitchClass) -> PitchError
DeriveT.out_of_range_error PitchClass
semis (PitchClass
0, PitchClass
max_semi)) forall a b. (a -> b) -> a -> b
$ do
            let a0 :: NoteNumber
a0 = forall a. Real a => a -> NoteNumber
Pitch.nn forall a b. (a -> b) -> a -> b
$ Control -> Y
get Control
a0_nn
            NoteNumber
nn <- Degrees
degrees forall a. Vector a -> PitchClass -> Maybe a
Vector.!? (Pitch -> PitchClass
Pitch.pitch_pc Pitch
pitch forall a. Num a => a -> a -> a
+ PitchClass
semis)
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ NoteNumber
a0 forall a. Num a => a -> a -> a
+ NoteNumber
nn
                forall a. Num a => a -> a -> a
+ forall a. Real a => a -> NoteNumber
Pitch.nn ((Pitch -> PitchClass
Pitch.pitch_octave Pitch
pitch forall a. Num a => a -> a -> a
+ PitchClass
octaves) forall a. Num a => a -> a -> a
* PitchClass
12)
        where
        octaves :: PitchClass
octaves = forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ Control -> Y
get Control
Controls.octave
        get :: Control -> Y
get Control
c = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Y
0 Control
c (PitchConfig -> Map Control Y
PSignal.pitch_controls PitchConfig
config)
    semis_to_note :: Pitch -> PitchClass -> Maybe Note
semis_to_note Pitch
pitch PitchClass
steps
        | Pitch -> PitchClass
Pitch.pitch_pc Pitch
pitch forall a. Num a => a -> a -> a
+ PitchClass
steps forall a. Ord a => a -> a -> Bool
>= PitchClass
per_octave = forall a. Maybe a
Nothing
        | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Pitch -> Note
show_pitch forall a b. (a -> b) -> a -> b
$ PitchClass -> PitchClass -> Pitch -> Pitch
Pitch.add_pc PitchClass
per_octave PitchClass
steps Pitch
pitch
    per_octave :: PitchClass
per_octave = forall a. Vector a -> PitchClass
Vector.length Degrees
degrees

input_to_note :: Pitch.PitchClass -> Scales.InputToNote
input_to_note :: PitchClass -> Environ -> Input -> Either PitchError Note
input_to_note PitchClass
per_octave Environ
_env (Pitch.Input KbdType
kbd Pitch
pitch Y
_frac) =
    Pitch -> Note
show_pitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KbdType
-> PitchClass -> PitchClass -> Pitch -> Either PitchError Pitch
Scales.kbd_to_scale KbdType
kbd PitchClass
per_octave PitchClass
0 Pitch
pitch