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

-- | Create val calls for scale degrees.  These are the calls that a scale
-- brings into scope, so they should be referenced from
-- 'Derive.scale_note_to_call' implementations.
module Derive.Call.ScaleDegree (
    -- * equal tempered
    scale_degree, pitch_expr
    -- * just
    , NamedIntervals
    , scale_degree_just, scale_degree_interval
    , interval_arg_doc, resolve_intervals
) where
import qualified Data.Map as Map
import qualified Data.Ratio as Ratio
import qualified Data.Text as Text

import qualified Util.Doc as Doc
import qualified Derive.Args as Args
import qualified Derive.Call.Module as Module
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Expr as Expr
import qualified Derive.PSignal as PSignal
import qualified Derive.Parse as Parse
import qualified Derive.Pitches as Pitches
import qualified Derive.Scale as Scale
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Sig as Sig

import qualified Perform.Pitch as Pitch

import           Global


-- * equal tempered

-- | Create a pitch val call for the given scale degree.  This is intended to
-- be used by scales to generate their calls, but of course each scale may
-- define calls in its own way.
scale_degree :: PSignal.Scale -> Scale.PitchNn -> Scale.PitchNote
    -> Derive.ValCall
scale_degree :: Scale -> PitchNn -> PitchNote -> ValCall
scale_degree Scale
scale PitchNn
pitch_nn PitchNote
pitch_note = Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Pitch)
-> ValCall
forall a.
ToVal a =>
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
Derive.val_call Module
Module.scale
    CallName
"pitch" Tags
forall a. Monoid a => a
mempty Doc
"Emit the pitch of a scale degree." (WithArgDoc (PassedArgs Tagged -> Deriver Pitch) -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver Pitch) -> ValCall
forall a b. (a -> b) -> a -> b
$
    Parser Hz
-> (Hz -> PassedArgs Tagged -> Deriver Pitch)
-> WithArgDoc (PassedArgs Tagged -> Deriver Pitch)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (ArgName -> Hz -> Doc -> Parser Hz
forall a.
(Typecheck a, ShowVal a) =>
ArgName -> a -> Doc -> Parser a
Sig.defaulted ArgName
"frac" Hz
0
        Doc
"Add this many hundredths of a scale degree to the output.")
    ((Hz -> PassedArgs Tagged -> Deriver Pitch)
 -> WithArgDoc (PassedArgs Tagged -> Deriver Pitch))
-> (Hz -> PassedArgs Tagged -> Deriver Pitch)
-> WithArgDoc (PassedArgs Tagged -> Deriver Pitch)
forall a b. (a -> b) -> a -> b
$ \Hz
frac PassedArgs Tagged
_args -> do
        Environ
env <- Deriver Environ
Derive.get_environ
        let config :: PitchConfig
config = Environ -> ControlValMap -> PitchConfig
PSignal.PitchConfig Environ
env ControlValMap
controls
            controls :: ControlValMap
controls = if Hz
frac Hz -> Hz -> Bool
forall a. Eq a => a -> a -> Bool
== Hz
0 then ControlValMap
forall a. Monoid a => a
mempty
                else Control -> Hz -> ControlValMap
forall k a. k -> a -> Map k a
Map.singleton Control
Controls.chromatic (Hz
frac Hz -> Hz -> Hz
forall a. Fractional a => a -> a -> a
/ Hz
100)
        Pitch -> Deriver Pitch
forall (m :: * -> *) a. Monad m => a -> m a
return (Pitch -> Deriver Pitch) -> Pitch -> Deriver Pitch
forall a b. (a -> b) -> a -> b
$! Scale -> PitchNn -> PitchNote -> PitchConfig -> Pitch
PSignal.pitch Scale
scale
            (\PitchConfig
config -> PitchConfig -> NoteNumber -> NoteNumber
add_absolute_transposers PitchConfig
config (NoteNumber -> NoteNumber)
-> Either PitchError NoteNumber -> Either PitchError NoteNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PitchNn
pitch_nn PitchConfig
config)
            PitchNote
pitch_note PitchConfig
config

-- | Apply transpose signals that don't require any scale knowledge.
add_absolute_transposers :: PSignal.PitchConfig -> Pitch.NoteNumber
    -> Pitch.NoteNumber
add_absolute_transposers :: PitchConfig -> NoteNumber -> NoteNumber
add_absolute_transposers PitchConfig
config NoteNumber
nn =
    Hz -> NoteNumber -> NoteNumber
Pitch.add_hz (Hz -> Control -> ControlValMap -> Hz
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Hz
0 Control
Controls.hz ControlValMap
controls)
        (NoteNumber
nn NoteNumber -> NoteNumber -> NoteNumber
forall a. Num a => a -> a -> a
+ Hz -> NoteNumber
forall a. Real a => a -> NoteNumber
Pitch.nn (Hz -> Control -> ControlValMap -> Hz
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Hz
0 Control
Controls.nn ControlValMap
controls))
    where controls :: ControlValMap
controls = PitchConfig -> ControlValMap
PSignal.pitch_controls PitchConfig
config

-- | Convert a note and @frac@ arg into a tracklang expression representing
-- that note.
--
-- TODO This is actually totally wrong, because a Pitch.Note isn't expected an
-- expression, but just the call part of the expression.  Other functions want
-- to parse it, and they're not expecting spaces in there.  What this should
-- actually do is return a real @Expr Text@, or a specialized version where
-- the Call is known to be a Pitch.Note.  But for that, scale_input_to_note
-- would have to change, and that would probably touch a lot of things.  So
-- for the moment, I leave this function in place to document where a
-- hypothetical pitch_expr should be called, but it doesn't actually do
-- anything.
pitch_expr :: Double -> Pitch.Note -> Pitch.Note
pitch_expr :: Hz -> Note -> Note
pitch_expr Hz
_frac Note
note = Note
note

_pitch_expr :: Double -> Pitch.Note -> Expr.Expr Expr.MiniVal
_pitch_expr :: Hz -> Note -> Expr MiniVal
_pitch_expr Hz
frac Note
note = Call MiniVal -> Expr MiniVal
forall val. Call val -> Expr val
Expr.generator (Call MiniVal -> Expr MiniVal) -> Call MiniVal -> Expr MiniVal
forall a b. (a -> b) -> a -> b
$ Symbol -> [MiniVal] -> Call MiniVal
forall val. Symbol -> [val] -> Call val
Expr.call (Note -> Symbol
note_symbol Note
note) ([MiniVal] -> Call MiniVal) -> [MiniVal] -> Call MiniVal
forall a b. (a -> b) -> a -> b
$
    if Hz
frac Hz -> Hz -> Bool
forall a. Eq a => a -> a -> Bool
== Hz
0 then []
    else [Int -> MiniVal
forall a. ToVal a => a -> MiniVal
Expr.to_val (Hz -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Hz
frac Hz -> Hz -> Hz
forall a. Num a => a -> a -> a
* Hz
100) :: Int)]

note_symbol :: Pitch.Note -> Expr.Symbol
note_symbol :: Note -> Symbol
note_symbol Note
note = Text -> Symbol
Expr.Symbol (Note -> Text
Pitch.note_text Note
note)

-- * just

-- | Map from named intervals to the interval's ratio.
type NamedIntervals = Map Text Ratio.Rational

-- | A fancier version of 'scale_degree' that takes interval arguments.
scale_degree_just :: PSignal.Scale -> NamedIntervals
    -> Pitch.Hz -- ^ add an arbitrary extra interval to the output
    -> Scale.PitchNn -> Scale.PitchNote -> Derive.ValCall
scale_degree_just :: Scale -> NamedIntervals -> Hz -> PitchNn -> PitchNote -> ValCall
scale_degree_just Scale
scale NamedIntervals
named_intervals Hz
extra_interval PitchNn
pitch_nn PitchNote
pitch_note =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Pitch)
-> ValCall
forall a.
ToVal a =>
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
Derive.val_call Module
Module.scale CallName
"pitch" Tags
forall a. Monoid a => a
mempty
    Doc
"Emit the pitch of a scale degree."
    (WithArgDoc (PassedArgs Tagged -> Deriver Pitch) -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver Pitch) -> ValCall
forall a b. (a -> b) -> a -> b
$ Parser [Either Hz Text]
-> ([Either Hz Text] -> PassedArgs Tagged -> Deriver Pitch)
-> WithArgDoc (PassedArgs Tagged -> Deriver Pitch)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (ArgName -> Doc -> Parser [Either Hz Text]
forall a. Typecheck a => ArgName -> Doc -> Parser [a]
Sig.many ArgName
"interval" (NamedIntervals -> Doc
interval_arg_doc NamedIntervals
named_intervals))
    (([Either Hz Text] -> PassedArgs Tagged -> Deriver Pitch)
 -> WithArgDoc (PassedArgs Tagged -> Deriver Pitch))
-> ([Either Hz Text] -> PassedArgs Tagged -> Deriver Pitch)
-> WithArgDoc (PassedArgs Tagged -> Deriver Pitch)
forall a b. (a -> b) -> a -> b
$ \[Either Hz Text]
intervals PassedArgs Tagged
_ -> do
        Hz
interval <- NamedIntervals -> [Either Hz Text] -> Deriver Hz
resolve_intervals NamedIntervals
named_intervals [Either Hz Text]
intervals
        Environ
env <- Deriver Environ
Derive.get_environ
        Pitch -> Deriver Pitch
forall (m :: * -> *) a. Monad m => a -> m a
return (Pitch -> Deriver Pitch) -> Pitch -> Deriver Pitch
forall a b. (a -> b) -> a -> b
$! Scale -> PitchNn -> PitchNote -> PitchConfig -> Pitch
PSignal.pitch Scale
scale
            (\PitchConfig
config -> Hz -> PitchConfig -> NoteNumber -> NoteNumber
modify (Hz
extra_intervalHz -> Hz -> Hz
forall a. Num a => a -> a -> a
*Hz
interval) PitchConfig
config (NoteNumber -> NoteNumber)
-> Either PitchError NoteNumber -> Either PitchError NoteNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                PitchNn
pitch_nn PitchConfig
config)
            PitchNote
pitch_note (Environ -> ControlValMap -> PitchConfig
PSignal.PitchConfig Environ
env ControlValMap
forall a. Monoid a => a
mempty)
    where
    modify :: Hz -> PitchConfig -> NoteNumber -> NoteNumber
modify Hz
interval PitchConfig
config = PitchConfig -> NoteNumber -> NoteNumber
add_absolute_transposers PitchConfig
config
        (NoteNumber -> NoteNumber)
-> (NoteNumber -> NoteNumber) -> NoteNumber -> NoteNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Hz -> Hz) -> NoteNumber -> NoteNumber
Pitch.modify_hz (Hz -> Hz -> Hz
forall a. Num a => a -> a -> a
*Hz
interval)

scale_degree_interval :: PSignal.Scale -> NamedIntervals -> Pitch.Note
    -> Maybe Derive.ValCall
scale_degree_interval :: Scale -> NamedIntervals -> Note -> Maybe ValCall
scale_degree_interval Scale
scale NamedIntervals
named_intervals Note
note =
    case NamedIntervals -> Note -> Maybe Hz
parse_relative_interval NamedIntervals
named_intervals Note
note of
        Maybe Hz
Nothing -> Maybe ValCall
forall a. Maybe a
Nothing
        Just Hz
interval ->
            ValCall -> Maybe ValCall
forall a. a -> Maybe a
Just (ValCall -> Maybe ValCall) -> ValCall -> Maybe ValCall
forall a b. (a -> b) -> a -> b
$ Scale -> NamedIntervals -> Hz -> ValCall
relative_scale_degree Scale
scale NamedIntervals
named_intervals Hz
interval

interval_arg_doc :: NamedIntervals -> Doc.Doc
interval_arg_doc :: NamedIntervals -> Doc
interval_arg_doc NamedIntervals
named_intervals =
    Doc
"Multiply this interval with the note's frequency. Negative numbers\
    \ divide, so while `3/2` goes up a fifth, `-3/2` goes down a fifth.\
    \ Can be either a ratio or a symbol drawn from: "
    Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
Doc.commas ((Text -> Doc) -> [Text] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc
Doc.literal (NamedIntervals -> [Text]
forall k a. Map k a -> [k]
Map.keys NamedIntervals
named_intervals))

parse_relative_interval :: NamedIntervals -> Pitch.Note -> Maybe Pitch.Hz
parse_relative_interval :: NamedIntervals -> Note -> Maybe Hz
parse_relative_interval NamedIntervals
named_intervals Note
note =
    Hz -> Hz
forall {a}. (Ord a, Fractional a) => a -> a
unsign (Hz -> Hz) -> Maybe Hz -> Maybe Hz
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamedIntervals -> Text -> Maybe Hz
resolve_interval NamedIntervals
named_intervals (Note -> Text
Pitch.note_text Note
note)
        Maybe Hz -> Maybe Hz -> Maybe Hz
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Hz
parse_num)
    where
    parse_num :: Maybe Hz
parse_num = case Text -> Either Text Val
Parse.parse_val (Note -> Text
Pitch.note_text Note
note) of
        Right (DeriveT.VNum (ScoreT.Typed Type
ScoreT.Untyped Hz
num)) -> Hz -> Maybe Hz
forall a. a -> Maybe a
Just Hz
num
        Either Text Val
_ -> Maybe Hz
forall a. Maybe a
Nothing
    unsign :: a -> a
unsign a
val = if a
val a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 then a -> a
forall a. Fractional a => a -> a
recip (a -> a
forall a. Num a => a -> a
abs a
val) else a
val

relative_scale_degree :: PSignal.Scale -> NamedIntervals -> Pitch.Hz
    -> Derive.ValCall
relative_scale_degree :: Scale -> NamedIntervals -> Hz -> ValCall
relative_scale_degree Scale
scale NamedIntervals
named_intervals Hz
initial_interval =
    Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver Pitch)
-> ValCall
forall a.
ToVal a =>
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
Derive.val_call Module
Module.scale CallName
"pitch" Tags
forall a. Monoid a => a
mempty
    Doc
"Emit a pitch that is a relative interval from the previous pitch." (WithArgDoc (PassedArgs Tagged -> Deriver Pitch) -> ValCall)
-> WithArgDoc (PassedArgs Tagged -> Deriver Pitch) -> ValCall
forall a b. (a -> b) -> a -> b
$
    Parser [Either Hz Text]
-> ([Either Hz Text] -> PassedArgs Tagged -> Deriver Pitch)
-> WithArgDoc (PassedArgs Tagged -> Deriver Pitch)
forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (ArgName -> Doc -> Parser [Either Hz Text]
forall a. Typecheck a => ArgName -> Doc -> Parser [a]
Sig.many ArgName
"interval" (NamedIntervals -> Doc
interval_arg_doc NamedIntervals
named_intervals))
    (([Either Hz Text] -> PassedArgs Tagged -> Deriver Pitch)
 -> WithArgDoc (PassedArgs Tagged -> Deriver Pitch))
-> ([Either Hz Text] -> PassedArgs Tagged -> Deriver Pitch)
-> WithArgDoc (PassedArgs Tagged -> Deriver Pitch)
forall a b. (a -> b) -> a -> b
$ \[Either Hz Text]
intervals PassedArgs Tagged
args -> do
        Hz
interval <- (Hz
initial_interval*) (Hz -> Hz) -> Deriver Hz -> Deriver Hz
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            NamedIntervals -> [Either Hz Text] -> Deriver Hz
resolve_intervals NamedIntervals
named_intervals [Either Hz Text]
intervals
        RealTime
start <- PassedArgs Tagged -> Deriver RealTime
forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Tagged
args
        Text -> Maybe Pitch -> Deriver Pitch
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"relative interval requires a previous pitch" (Maybe Pitch -> Deriver Pitch) -> Maybe Pitch -> Deriver Pitch
forall a b. (a -> b) -> a -> b
$ do
            Derive.TagPitch PSignal
prev <- PassedArgs Tagged -> Maybe Tagged
forall a. PassedArgs a -> Maybe a
Args.prev_val PassedArgs Tagged
args
            Scale -> (Hz -> Hz) -> Pitch -> Pitch
Pitches.modify_hz Scale
scale (Hz -> Hz -> Hz
forall a. Num a => a -> a -> a
*Hz
interval) (Pitch -> Pitch) -> Maybe Pitch -> Maybe Pitch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealTime -> PSignal -> Maybe Pitch
PSignal.at RealTime
start PSignal
prev

resolve_intervals :: NamedIntervals -> [Either Pitch.Hz Text]
    -> Derive.Deriver Pitch.Hz
resolve_intervals :: NamedIntervals -> [Either Hz Text] -> Deriver Hz
resolve_intervals NamedIntervals
named_intervals [Either Hz Text]
intervals =
    [Hz] -> Hz
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ([Hz] -> Hz) -> ([Hz] -> [Hz]) -> [Hz] -> Hz
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Hz -> Hz) -> [Hz] -> [Hz]
forall a b. (a -> b) -> [a] -> [b]
map Hz -> Hz
forall {a}. (Ord a, Fractional a) => a -> a
unsign ([Hz] -> Hz) -> Deriver State Error [Hz] -> Deriver Hz
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Either Hz Text -> Deriver Hz)
-> [Either Hz Text] -> Deriver State Error [Hz]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Hz -> Deriver Hz)
-> (Text -> Deriver Hz) -> Either Hz Text -> Deriver Hz
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Hz -> Deriver Hz
forall (m :: * -> *) a. Monad m => a -> m a
return Text -> Deriver Hz
resolve) [Either Hz Text]
intervals
    where
    resolve :: Text -> Deriver Hz
resolve Text
text = Text -> Maybe Hz -> Deriver Hz
forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require (Text
"unknown named interval: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
showt Text
text) (Maybe Hz -> Deriver Hz) -> Maybe Hz -> Deriver Hz
forall a b. (a -> b) -> a -> b
$
        NamedIntervals -> Text -> Maybe Hz
resolve_interval NamedIntervals
named_intervals Text
text
    unsign :: a -> a
unsign a
val = if a
val a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 then a -> a
forall a. Fractional a => a -> a
recip (a -> a
forall a. Num a => a -> a
abs a
val) else a
val

resolve_interval :: NamedIntervals -> Text -> Maybe Pitch.Hz
resolve_interval :: NamedIntervals -> Text -> Maybe Hz
resolve_interval NamedIntervals
named_intervals Text
text = case Text -> Maybe (Char, Text)
Text.uncons Text
text of
    Just (Char
'-', Text
text) -> Hz -> Hz
forall a. Num a => a -> a
negate (Hz -> Hz) -> Maybe Hz -> Maybe Hz
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe Hz
forall {b}. Fractional b => Text -> Maybe b
lookup Text
text
    Maybe (Char, Text)
_ -> Text -> Maybe Hz
forall {b}. Fractional b => Text -> Maybe b
lookup Text
text
    where lookup :: Text -> Maybe b
lookup Text
text = Rational -> b
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Rational -> b) -> Maybe Rational -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> NamedIntervals -> Maybe Rational
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
text NamedIntervals
named_intervals