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

-- | Harmonic series.
module Derive.Scale.Harmonic where
import qualified Data.Attoparsec.Text as A
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Text as Text

import qualified Util.Lists as Lists
import qualified Util.ParseText as ParseText
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.Scale.Theory as Theory
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal

import qualified Perform.Pitch as Pitch

import           Global

-- TODO There's no easy way to enter negative harmonics.  Maybe I'd need some
-- kind of alternate input mode that could affect input_to_note.

scales :: [Scale.Definition]
scales :: [Definition]
scales = (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ Scale -> Definition
Scale.Simple forall a b. (a -> b) -> a -> b
$ Scale.Scale
    { scale_id :: ScaleId
scale_id = ScaleId
scale_id
    , scale_pattern :: Text
scale_pattern = Text
"[" forall a. Semigroup a => a -> a -> a
<> String -> Text
txt String
octaves forall a. Semigroup a => a -> a -> a
<> Text
"]-?[0-9]+"
    , 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
$ Note -> Either PitchError Pitch
read_pitch
    , 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
    -- This scale doesn't actually have a layout, but for the purposes of
    -- Pitch.Pitch math, it acts like alternating white and black keys.
    , scale_layout :: Layout
scale_layout = [PitchClass] -> Layout
Scale.layout (forall a. PitchClass -> a -> [a]
replicate PitchClass
20 PitchClass
2)
    , scale_transpose :: Transpose
scale_transpose = Transpose
transpose
    , scale_enharmonics :: Enharmonics
scale_enharmonics = Enharmonics
Scales.no_enharmonics
    , scale_note_to_call :: Note -> Maybe ValCall
scale_note_to_call = Scale -> Note -> Maybe ValCall
note_to_call Scale
scale
    , scale_input_to_note :: Environ -> Input -> Either PitchError Note
scale_input_to_note = Environ -> Input -> Either PitchError Note
input_to_note
    , 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 Environ -> Input -> Either PitchError Note
input_to_note (Scale -> Note -> Maybe ValCall
note_to_call Scale
scale)
    , 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
    doc :: Doc
doc = Doc
"The harmonic series. The NN frequency of 一1 is set by "
        forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Control
unity_control forall a. Semigroup a => a -> a -> a
<> Doc
", and defaults to 0nn. This puts\
        \ 五1 at middle C, which is where 四1 would normally be, but since the\
        \ first degree is the octave, putting 四1 at middle C would get too\
        \ high too quickly.\n\
        \ Negative numbers are the nth undertone, i.e. `1 / abs n`."
    scale :: Scale
scale = ScaleId -> Set Control -> Scale
PSignal.Scale ScaleId
scale_id Set Control
transposers
    scale_id :: ScaleId
scale_id = ScaleId
"harmonic"

-- | Frequency for 一1.
unity_control :: ScoreT.Control
unity_control :: Control
unity_control = Control
"unity"

read_pitch :: Pitch.Note -> Either DeriveT.PitchError Pitch.Pitch
read_pitch :: Note -> Either PitchError Pitch
read_pitch 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 Text PitchClass
p_octave forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text PitchClass
ParseText.p_int)
        (Note -> Text
Pitch.note_text Note
note)
    where
    p_octave :: Parser Text PitchClass
p_octave = do
        Char
c <- Parser Char
A.anyChar
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. MonadPlus m => m a
mzero (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+PitchClass
1)) forall a b. (a -> b) -> a -> b
$ forall a. Eq a => a -> [a] -> Maybe PitchClass
List.elemIndex Char
c String
octaves

octaves :: [Char]
octaves :: String
octaves = String
"一二三四五六七八久十"

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
$ Text
oct_s forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt PitchClass
pc
    where
    oct_s :: Text
oct_s = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Show a => a -> Text
showt PitchClass
oct forall a. Semigroup a => a -> a -> a
<> Text
"-") Char -> Text
Text.singleton (forall a. [a] -> PitchClass -> Maybe a
Lists.at String
octaves (PitchClass
octforall a. Num a => a -> a -> a
-PitchClass
1))

transpose :: Derive.Transpose
transpose :: Transpose
transpose Transposition
_transposition Environ
_env PitchClass
steps (Pitch.Pitch PitchClass
oct (Pitch.Degree PitchClass
pc PitchClass
_)) =
    forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ PitchClass -> Degree -> Pitch
Pitch.Pitch PitchClass
oct (PitchClass -> PitchClass -> Degree
Pitch.Degree (PitchClass
pc forall a. Num a => a -> a -> a
+ PitchClass
steps) PitchClass
0)

note_to_call :: PSignal.Scale -> Pitch.Note -> Maybe Derive.ValCall
note_to_call :: Scale -> Note -> Maybe ValCall
note_to_call Scale
scale 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
$ Note -> Either PitchError Pitch
read_pitch 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. Maybe a
Nothing Scale
scale
        (forall {a}.
Pitch -> PitchConfig -> PitchClass -> Either a NoteNumber
semis_to_nn Pitch
pitch) (Pitch -> PitchClass -> Maybe Note
semis_to_note Pitch
pitch)
    where
    semis_to_nn :: Pitch -> PitchConfig -> PitchClass -> Either a NoteNumber
semis_to_nn (Pitch.Pitch PitchClass
oct (Pitch.Degree PitchClass
pc PitchClass
_)) PitchConfig
config PitchClass
semis =
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Hz -> NoteNumber
Pitch.hz_to_nn Hz
hz
        where
        hz :: Hz
hz = NoteNumber -> Hz
Pitch.nn_to_hz (forall a. Real a => a -> NoteNumber
Pitch.nn (Control -> Hz
get Control
unity_control))
            forall a. Num a => a -> a -> a
* Hz
2forall a b. (Num a, Integral b) => a -> b -> a
^(PitchClass
oct forall a. Num a => a -> a -> a
+ forall a b. (RealFrac a, Integral b) => a -> b
floor (Control -> Hz
get Control
Controls.octave))
            forall a. Num a => a -> a -> a
* forall {a} {a}. (Integral a, Fractional a) => a -> a
harmonic (PitchClass
pc forall a. Num a => a -> a -> a
+ PitchClass
semis)
        harmonic :: a -> a
harmonic a
n
            | a
n forall a. Eq a => a -> a -> Bool
== a
0 = a
1
            | a
n forall a. Ord a => a -> a -> Bool
> a
0 = forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n
            | Bool
otherwise = a
1 forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Num a => a -> a
abs a
n)
        get :: Control -> Hz
get Control
c = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Hz
0 Control
c (PitchConfig -> Map Control Hz
PSignal.pitch_controls PitchConfig
config)
    semis_to_note :: Pitch -> PitchClass -> Maybe Note
semis_to_note Pitch
pitch PitchClass
steps = 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 -> Pitch -> Pitch
add_pc PitchClass
steps Pitch
pitch
    add_pc :: PitchClass -> Pitch -> Pitch
add_pc PitchClass
steps (Pitch.Pitch PitchClass
oct (Pitch.Degree PitchClass
pc PitchClass
accs)) =
        PitchClass -> Degree -> Pitch
Pitch.Pitch PitchClass
oct (PitchClass -> PitchClass -> Degree
Pitch.Degree (PitchClass
pc forall a. Num a => a -> a -> a
+ PitchClass
steps) PitchClass
accs)

input_to_note :: Scales.InputToNote
input_to_note :: Environ -> Input -> Either PitchError Note
input_to_note Environ
_ Input
input =
    Pitch -> Note
show_pitch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall err a. err -> Maybe a -> Either err a
justErr PitchError
DeriveT.InvalidInput (Input -> Maybe Pitch
input_to_pitch Input
input)

input_to_pitch :: Pitch.Input -> Maybe Pitch.Pitch
input_to_pitch :: Input -> Maybe Pitch
input_to_pitch (Pitch.Input KbdType
kbd p :: Pitch
p@(Pitch.Pitch PitchClass
oct (Pitch.Degree PitchClass
pc PitchClass
acc)) Hz
_) =
    case KbdType
kbd of
        KbdType
Pitch.PianoKbd -> Pitch -> Pitch
expand forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PitchClass -> PitchClass -> Pitch -> Maybe Pitch
Scales.piano_kbd_pitch PitchClass
0 PitchClass
14 Pitch
p
        -- This gives 19 harmonics on the bottom row, and 18 on the top row.
        KbdType
Pitch.AsciiKbd -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall pc. Enum pc => PitchClass -> pc -> Pitch
Pitch.pitch PitchClass
oct (PitchClass
pc forall a. Num a => a -> a -> a
* PitchClass
2 forall a. Num a => a -> a -> a
+ PitchClass
acc forall a. Num a => a -> a -> a
+ PitchClass
1)
    where
    -- Make black keys into diatonic steps, so I can get 24 harmonics in a two
    -- octave range.
    expand :: Pitch -> Pitch
expand (Pitch.Pitch PitchClass
oct Degree
degree) =
        forall pc. Enum pc => PitchClass -> pc -> Pitch
Pitch.pitch PitchClass
oct (Layout -> Degree -> PitchClass
Theory.degree_to_semis Layout
Theory.piano_layout Degree
degree)