-- 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 = forall a.
ToVal a =>
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
Derive.val_call Module
Module.scale
    CallName
"pitch" forall a. Monoid a => a
mempty Doc
"Emit the pitch of a scale degree." forall a b. (a -> b) -> a -> b
$
    forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"frac" (Hz
0 :: Double)
        Doc
"Add this many hundredths of a scale degree to the output.")
    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 forall a. Eq a => a -> a -> Bool
== Hz
0 then forall a. Monoid a => a
mempty
                else forall k a. k -> a -> Map k a
Map.singleton Control
Controls.chromatic (Hz
frac forall a. Fractional a => a -> a -> a
/ Hz
100)
        forall (m :: * -> *) a. Monad m => a -> m a
return 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 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 (forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Hz
0 Control
Controls.hz ControlValMap
controls)
        (NoteNumber
nn forall a. Num a => a -> a -> a
+ forall a. Real a => a -> NoteNumber
Pitch.nn (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 = forall val. Call val -> Expr val
Expr.generator forall a b. (a -> b) -> a -> b
$ forall val. Symbol -> [val] -> Call val
Expr.call (Note -> Symbol
note_symbol Note
note) forall a b. (a -> b) -> a -> b
$
    if Hz
frac forall a. Eq a => a -> a -> Bool
== Hz
0 then []
    else [forall a. ToVal a => a -> MiniVal
Expr.to_val (forall a b. (RealFrac a, Integral b) => a -> b
floor (Hz
frac 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 =
    forall a.
ToVal a =>
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
Derive.val_call Module
Module.scale CallName
"pitch" forall a. Monoid a => a
mempty
    Doc
"Emit the pitch of a scale degree."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (forall a. Typecheck a => ArgName -> Doc -> Parser [a]
Sig.many ArgName
"interval" (NamedIntervals -> Doc
interval_arg_doc NamedIntervals
named_intervals))
    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
        forall (m :: * -> *) a. Monad m => a -> m a
return 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_intervalforall a. Num a => a -> a -> a
*Hz
interval) PitchConfig
config 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 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
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Hz -> Hz) -> NoteNumber -> NoteNumber
Pitch.modify_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 -> forall a. Maybe a
Nothing
        Just Hz
interval ->
            forall a. a -> Maybe a
Just 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: "
    forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
Doc.commas (forall a b. (a -> b) -> [a] -> [b]
map Text -> Doc
Doc.literal (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 =
    forall {a}. (Ord a, Fractional a) => a -> a
unsign 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)
        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 Val
val
            | Just (ScoreT.Typed Type
ScoreT.Untyped Hz
num)
                <- Val -> Maybe (Typed Hz)
DeriveT.constant_val Val
val -> forall a. a -> Maybe a
Just Hz
num
        Either Text Val
_ -> forall a. Maybe a
Nothing
    unsign :: a -> a
unsign a
val = if a
val forall a. Ord a => a -> a -> Bool
< a
0 then forall a. Fractional a => a -> a
recip (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 =
    forall a.
ToVal a =>
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
Derive.val_call Module
Module.scale CallName
"pitch" forall a. Monoid a => a
mempty
    Doc
"Emit a pitch that is a relative interval from the previous pitch." forall a b. (a -> b) -> a -> b
$
    forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (forall a. Typecheck a => ArgName -> Doc -> Parser [a]
Sig.many ArgName
"interval" (NamedIntervals -> Doc
interval_arg_doc NamedIntervals
named_intervals))
    forall a b. (a -> b) -> a -> b
$ \[Either Hz Text]
intervals PassedArgs Tagged
args -> do
        Hz
interval <- (Hz
initial_interval*) 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 <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Tagged
args
        forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require Text
"relative interval requires a previous pitch" forall a b. (a -> b) -> a -> b
$ do
            Derive.TagPitch PSignal
prev <- forall a. PassedArgs a -> Maybe a
Args.prev_val PassedArgs Tagged
args
            Scale -> (Hz -> Hz) -> Pitch -> Pitch
Pitches.modify_hz Scale
scale (forall a. Num a => a -> a -> a
*Hz
interval) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PSignal -> RealTime -> Maybe Pitch
PSignal.at PSignal
prev RealTime
start

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 =
    forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (Ord a, Fractional a) => a -> a
unsign forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either 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 = forall a. HasCallStack => Text -> Maybe a -> Deriver a
Derive.require (Text
"unknown named interval: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
text) 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 forall a. Ord a => a -> a -> Bool
< a
0 then forall a. Fractional a => a -> a
recip (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) -> forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {b}. Fractional b => Text -> Maybe b
lookup Text
text
    Maybe (Char, Text)
_ -> forall {b}. Fractional b => Text -> Maybe b
lookup Text
text
    where lookup :: Text -> Maybe b
lookup Text
text = forall a b. (Real a, Fractional b) => a -> b
realToFrac forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
text NamedIntervals
named_intervals