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

-- | Calls and functions for 'DeriveT.CFunction's.
module Derive.C.Prelude.ControlFunction (
    library
    , c_cf_rnd_around
) where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified System.Random.Mersenne.Pure64 as Pure64

import qualified Util.Doc as Doc
import qualified Util.Lists as Lists
import qualified Util.Num as Num

import qualified Derive.Call as Call
import qualified Derive.Call.ControlUtil as ControlUtil
import qualified Derive.Call.Make as Make
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Tags as Tags
import qualified Derive.Controls as Controls
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Env as Env
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Expr as Expr
import qualified Derive.Library as Library
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal
import qualified Derive.Sig as Sig
import qualified Derive.Typecheck as Typecheck
import qualified Derive.ValType as ValType
import qualified Derive.Warp as Warp

import qualified Perform.RealTime as RealTime
import qualified Perform.Signal as Signal
import qualified Ui.Meter.Mark as Mark
import qualified Ui.Meter.Meter as Meter
import qualified Ui.Ruler as Ruler
import qualified Ui.ScoreTime as ScoreTime

import           Global
import           Types


library :: Library.Library
library :: Library
library = [(Symbol, ValCall)] -> Library
Library.vals forall a b. (a -> b) -> a -> b
$
    [ (Symbol
"cf-rnd", (Double -> Double -> Double) -> ValCall
c_cf_rnd forall a b. a -> b -> a
const)
    , (Symbol
"cf-rnd+", (Double -> Double -> Double) -> ValCall
c_cf_rnd forall a. Num a => a -> a -> a
(+))
    , (Symbol
"cf-rnd*", (Double -> Double -> Double) -> ValCall
c_cf_rnd forall a. Num a => a -> a -> a
(*))
    , (Symbol
"cf-rnd-a", (Double -> Double -> Double) -> ValCall
c_cf_rnd_around forall a b. a -> b -> a
const)
    , (Symbol
"cf-rnd-a+", (Double -> Double -> Double) -> ValCall
c_cf_rnd_around forall a. Num a => a -> a -> a
(+))
    , (Symbol
"cf-rnd-a*", (Double -> Double -> Double) -> ValCall
c_cf_rnd_around forall a. Num a => a -> a -> a
(*))
    , (Symbol
"cf-rnd01", ValCall
c_cf_rnd01)
    , (Symbol
"cf-swing", ValCall
c_cf_swing)
    , (Symbol
"cf-clamp", ValCall
c_cf_clamp)
    ] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (Maybe Doc -> CurveD -> (Symbol, ValCall)
make_curve_call forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Symbol, CurveD)]
ControlUtil.standard_curves
    forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe Doc -> CurveD -> (Symbol, ValCall)
make_curve_call forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. a -> Maybe a
Just) [(Doc, CurveD)]
curves

make_curve_call :: Maybe Doc.Doc -> ControlUtil.CurveD
    -> (Expr.Symbol, Derive.ValCall)
make_curve_call :: Maybe Doc -> CurveD -> (Symbol, ValCall)
make_curve_call Maybe Doc
doc CurveD
curve =
    ( Symbol
"curve-" forall a. Semigroup a => a -> a -> a
<> Text -> Symbol
Expr.Symbol (CurveD -> Text
ControlUtil.curve_name CurveD
curve)
    , Maybe Doc -> CurveD -> ValCall
ControlUtil.make_curve_call Maybe Doc
doc CurveD
curve
    )

data Distribution =
    Uniform
    -- | Approximate a bounded normal distribution.
    | Normal
    -- | This is like Normal, but rotated, so the peaks are at the extremities.
    | Bimodal
    deriving (Distribution
forall a. a -> a -> Bounded a
maxBound :: Distribution
$cmaxBound :: Distribution
minBound :: Distribution
$cminBound :: Distribution
Bounded, Distribution -> Distribution -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Distribution -> Distribution -> Bool
$c/= :: Distribution -> Distribution -> Bool
== :: Distribution -> Distribution -> Bool
$c== :: Distribution -> Distribution -> Bool
Eq, Int -> Distribution
Distribution -> Int
Distribution -> [Distribution]
Distribution -> Distribution
Distribution -> Distribution -> [Distribution]
Distribution -> Distribution -> Distribution -> [Distribution]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Distribution -> Distribution -> Distribution -> [Distribution]
$cenumFromThenTo :: Distribution -> Distribution -> Distribution -> [Distribution]
enumFromTo :: Distribution -> Distribution -> [Distribution]
$cenumFromTo :: Distribution -> Distribution -> [Distribution]
enumFromThen :: Distribution -> Distribution -> [Distribution]
$cenumFromThen :: Distribution -> Distribution -> [Distribution]
enumFrom :: Distribution -> [Distribution]
$cenumFrom :: Distribution -> [Distribution]
fromEnum :: Distribution -> Int
$cfromEnum :: Distribution -> Int
toEnum :: Int -> Distribution
$ctoEnum :: Int -> Distribution
pred :: Distribution -> Distribution
$cpred :: Distribution -> Distribution
succ :: Distribution -> Distribution
$csucc :: Distribution -> Distribution
Enum, Int -> Distribution -> ShowS
[Distribution] -> ShowS
Distribution -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Distribution] -> ShowS
$cshowList :: [Distribution] -> ShowS
show :: Distribution -> [Char]
$cshow :: Distribution -> [Char]
showsPrec :: Int -> Distribution -> ShowS
$cshowsPrec :: Int -> Distribution -> ShowS
Show)

instance ShowVal.ShowVal Distribution
instance Typecheck.Typecheck Distribution
instance Typecheck.ToVal Distribution

c_cf_rnd :: (Signal.Y -> Signal.Y -> Signal.Y) -> Derive.ValCall
c_cf_rnd :: (Double -> Double -> Double) -> ValCall
c_cf_rnd Double -> Double -> Double
combine = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"cf-rnd" (Tags
Tags.control_function forall a. Semigroup a => a -> a -> a
<> Tags
Tags.random)
    Doc
"Randomize a control. Normally it replaces the control of the same name,\
    \ while the `+` and `*` variants add to and multiply with it."
    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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"low" Doc
"Low end of the range."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"high" Doc
"High end of the range."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"distribution" EnvironDefault
Sig.Prefixed Distribution
Normal Doc
"Random distribution."
    ) forall a b. (a -> b) -> a -> b
$ \(Double
low, Double
high, Distribution
distribution) PassedArgs Tagged
_args -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$!
        Text -> (Dynamic -> Control -> RealTime -> Double) -> CFunction
make_cf Text
"cf-rnd" forall a b. (a -> b) -> a -> b
$ \Dynamic
cf_dyn Control
control RealTime
pos -> Double -> Double -> Double
combine
            (Distribution -> Double -> Double -> [Double] -> Double
cf_rnd Distribution
distribution Double
low Double
high (RealTime -> Double -> [Double]
random_stream RealTime
pos (Dynamic -> Double
dyn_seed Dynamic
cf_dyn)))
            (forall {k} (kind :: k). Signal kind -> RealTime -> Double
Signal.at Control
control RealTime
pos)

make_cf :: Text -> (DeriveT.Dynamic -> Signal.Control -> RealTime -> Signal.Y)
    -> DeriveT.CFunction
make_cf :: Text -> (Dynamic -> Control -> RealTime -> Double) -> CFunction
make_cf Text
name Dynamic -> Control -> RealTime -> Double
f = DeriveT.CFunction
    { cf_name :: Text
cf_name = Text
name
    , cf_signal :: TypedSignal
cf_signal = forall a. a -> Typed a
ScoreT.untyped (forall {k} (kind :: k). Double -> Signal kind
Signal.constant Double
0)
    , cf_function :: Dynamic -> Control -> RealTime -> Double
cf_function = Dynamic -> Control -> RealTime -> Double
f
    }

c_cf_rnd_around :: (Signal.Y -> Signal.Y -> Signal.Y) -> Derive.ValCall
c_cf_rnd_around :: (Double -> Double -> Double) -> ValCall
c_cf_rnd_around Double -> Double -> Double
combine = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"cf-rnd-a"
    (Tags
Tags.control_function forall a. Semigroup a => a -> a -> a
<> Tags
Tags.random)
    Doc
"Randomize a control around a center point.\
    \ Normally it replaces the control of the same name,\
    \ while the `+` and `*` variants add to and multiply with it."
    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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"range" Doc
"Range this far from the center."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"center" (Double
0 :: Double) Doc
"Center of the range."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.environ ArgName
"distribution" EnvironDefault
Sig.Prefixed Distribution
Normal Doc
"Random distribution."
    ) forall a b. (a -> b) -> a -> b
$ \(Double
range, Double
center, Distribution
distribution) PassedArgs Tagged
_args -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$!
        Text -> (Dynamic -> Control -> RealTime -> Double) -> CFunction
make_cf Text
"cf-rnd-a" forall a b. (a -> b) -> a -> b
$ \Dynamic
cf_dyn Control
control RealTime
pos -> Double -> Double -> Double
combine
            (Distribution -> Double -> Double -> [Double] -> Double
cf_rnd Distribution
distribution (Double
centerforall a. Num a => a -> a -> a
-Double
range) (Double
centerforall a. Num a => a -> a -> a
+Double
range)
                (RealTime -> Double -> [Double]
random_stream RealTime
pos (Dynamic -> Double
dyn_seed Dynamic
cf_dyn)))
            (forall {k} (kind :: k). Signal kind -> RealTime -> Double
Signal.at Control
control RealTime
pos)

c_cf_rnd01 :: Derive.ValCall
c_cf_rnd01 :: ValCall
c_cf_rnd01 = ValCall -> Module -> CallName -> Doc -> (Val -> Val) -> ValCall
Make.modify_vcall ((Double -> Double -> Double) -> ValCall
c_cf_rnd forall a. Num a => a -> a -> a
(+)) Module
Module.prelude CallName
"cf-rnd01"
    Doc
"This is an abbreviation for `(cf-clamp (cf-rnd+ ..) 0 1)`." forall a b. (a -> b) -> a -> b
$
    \Val
val -> case forall a. Typecheck a => Val -> Maybe a
Typecheck.from_val_simple Val
val of
        Just CFunction
cf -> forall a. ToVal a => a -> Val
Typecheck.to_val forall a b. (a -> b) -> a -> b
$ Text -> (Double -> Double) -> CFunction -> CFunction
cf_compose Text
"cf-rnd01" (forall a. Ord a => a -> a -> a -> a
Num.clamp Double
0 Double
1) CFunction
cf
        Maybe CFunction
Nothing -> Val
val

cf_rnd :: Distribution -> Double -> Double -> [Double] -> Double
cf_rnd :: Distribution -> Double -> Double -> [Double] -> Double
cf_rnd Distribution
dist Double
low Double
high [Double]
rnds = forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale Double
low Double
high forall a b. (a -> b) -> a -> b
$ case Distribution
dist of
    Distribution
Uniform -> forall a. [a] -> a
head [Double]
rnds
    Distribution
Normal -> Double -> [Double] -> Double
Call.make_normal Double
1 [Double]
rnds
    Distribution
Bimodal
        | Double
v forall a. Ord a => a -> a -> Bool
>= Double
0.5 -> Double
v forall a. Num a => a -> a -> a
- Double
0.5
        | Bool
otherwise -> Double
v forall a. Num a => a -> a -> a
+ Double
0.5
        where v :: Double
v = Double -> [Double] -> Double
Call.make_normal Double
1 [Double]
rnds

random_stream :: RealTime -> Double -> [Double]
random_stream :: RealTime -> Double -> [Double]
random_stream RealTime
pos =
    forall b a. (b -> Maybe (a, b)) -> b -> [a]
List.unfoldr (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. PureMT -> (Double, PureMT)
Pure64.randomDouble) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> PureMT
Pure64.pureMT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
floor
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
+ RealTime -> Double
RealTime.to_seconds RealTime
pos)


-- * cf-swing

c_cf_swing :: Derive.ValCall
c_cf_swing :: ValCall
c_cf_swing = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"cf-swing" Tags
Tags.control_function
    (Doc
"Add a curved  offset to the control, suitable for swing tempo when added\
    \ to " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Control
Controls.start_s forall a. Semigroup a => a -> a -> a
<> Doc
". The curve is a sine wave,\
    \ from trough to trough.")
    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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"rank" Rank
Meter.Q
        Doc
"The time steps are on the beat, and midway between offset by the\
        \ given amount."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"amount" (Control -> RealTime -> ControlRef
make_ref Control
"swing" (RealTime
1forall a. Fractional a => a -> a -> a
/RealTime
3))
        Doc
"Swing amount, multiplied by the rank duration / 2."
    ) forall a b. (a -> b) -> a -> b
$ \(Rank
rank, Val
amount) PassedArgs Tagged
_args -> do
        Ref
amount <- Val -> Deriver Ref
from_control_ref Val
amount
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Text -> (Dynamic -> Control -> RealTime -> Double) -> CFunction
make_cf Text
"cf-swing" (forall {k} {kind :: k}.
Rank -> Ref -> Dynamic -> Signal kind -> RealTime -> Double
swing Rank
rank Ref
amount)
    where
    swing :: Rank -> Ref -> Dynamic -> Signal kind -> RealTime -> Double
swing Rank
rank Ref
amount Dynamic
cf_dyn Signal kind
control RealTime
pos
        | Just Marklist
marks <- Maybe Marklist
maybe_marks =
            forall {k} (kind :: k). Signal kind -> RealTime -> Double
Signal.at Signal kind
control RealTime
pos forall a. Num a => a -> a -> a
+ RealTime -> Double
RealTime.to_seconds (Marklist -> RealTime
swing Marklist
marks)
        | Bool
otherwise = Double
0
        where
        swing :: Marklist -> RealTime
swing Marklist
marks = (ScoreTime -> RealTime)
-> Rank
-> (RealTime -> Double)
-> Marklist
-> ScoreTime
-> RealTime
cf_swing (Dynamic -> ScoreTime -> RealTime
real Dynamic
cf_dyn) Rank
rank
            (Dynamic -> Double -> Ref -> RealTime -> Double
to_function Dynamic
cf_dyn Double
0 Ref
amount) Marklist
marks (Dynamic -> RealTime -> ScoreTime
score Dynamic
cf_dyn RealTime
pos)
        maybe_marks :: Maybe Marklist
maybe_marks = forall a b. (a, b) -> b
snd 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
Ruler.meter_name (Dynamic -> Marklists
DeriveT.dyn_ruler Dynamic
cf_dyn)

-- | TODO Hacky ref, should be temporary until I clean up cfs.
type Ref = Either DeriveT.ControlRef (ScoreT.Typed Signal.Y)

-- | I intentionally don't have Typecheck ControlRef, because in almost
-- all cases it should just be a scalar or function.  But ControlFunctions
-- are like little calls, so they need to delay control resolution just
-- like calls do, so they wind up duplicating all that.  TODO if I'm able to
-- unify calls and ControlFunctions then this goes away.
from_control_ref :: DeriveT.Val -> Derive.Deriver Ref
from_control_ref :: Val -> Deriver Ref
from_control_ref = \case
    DeriveT.VControlRef ControlRef
ref -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ControlRef
ref
    Val
val | Just Typed Double
num <- Val -> Maybe (Typed Double)
DeriveT.constant_val Val
val -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Typed Double
num
    Val
val -> forall a. HasCallStack => Text -> Deriver a
Derive.throw forall a b. (a -> b) -> a -> b
$ Text
"expected ControlRef or Num, but got "
        forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Val -> Type
ValType.specific_type_of Val
val)

-- | Defaulted control from a RealTime.
make_ref :: ScoreT.Control -> RealTime -> DeriveT.ControlRef
make_ref :: Control -> RealTime -> ControlRef
make_ref Control
c RealTime
deflt = forall control val. control -> Maybe val -> Ref control val
DeriveT.Ref Control
c forall a b. (a -> b) -> a -> b
$
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Typed a
ScoreT.untyped forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). Double -> Signal kind
Signal.constant (RealTime -> Double
RealTime.to_seconds RealTime
deflt)

cf_swing :: (ScoreTime -> RealTime) -> Meter.Rank -> ScoreT.Function
    -> Mark.Marklist -> ScoreTime -> RealTime
cf_swing :: (ScoreTime -> RealTime)
-> Rank
-> (RealTime -> Double)
-> Marklist
-> ScoreTime
-> RealTime
cf_swing ScoreTime -> RealTime
to_real Rank
rank RealTime -> Double
amount Marklist
marks ScoreTime
pos = case Rank -> Marklist -> ScoreTime -> Maybe (ScoreTime, ScoreTime)
marks_around Rank
rank Marklist
marks ScoreTime
pos of
    Maybe (ScoreTime, ScoreTime)
Nothing -> RealTime
0
    Just (ScoreTime
pre, ScoreTime
post) -> (ScoreTime -> RealTime
to_real ScoreTime
post forall a. Num a => a -> a -> a
- ScoreTime -> RealTime
to_real ScoreTime
pre) forall a. Fractional a => a -> a -> a
/ RealTime
2
        forall a. Num a => a -> a -> a
* Double -> RealTime
RealTime.seconds (RealTime -> Double
amount (ScoreTime -> RealTime
to_real ScoreTime
pos))
        forall a. Num a => a -> a -> a
* ScoreTime -> RealTime
swing (forall a. (Eq a, Fractional a) => a -> a -> a -> a
Num.normalize ScoreTime
pre ScoreTime
post ScoreTime
pos)

marks_around :: Meter.Rank -> Mark.Marklist -> ScoreTime
    -> Maybe (ScoreTime, ScoreTime)
marks_around :: Rank -> Marklist -> ScoreTime -> Maybe (ScoreTime, ScoreTime)
marks_around Rank
rank Marklist
marks ScoreTime
pos =
    (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {b}. [(b, Mark)] -> Maybe b
get (ScoreTime -> Marklist -> [PosMark]
Mark.descending ScoreTime
pos Marklist
marks) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {b}. [(b, Mark)] -> Maybe b
get (ScoreTime -> Marklist -> [PosMark]
Mark.ascending ScoreTime
pos Marklist
marks)
    where get :: [(b, Mark)] -> Maybe b
get = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
Lists.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
<=Rank
rank) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mark -> Rank
Mark.mark_rank forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)

swing :: ScoreTime -- ^ time from this beat to the next, normalized 0 to 1
    -> RealTime -- ^ amount of swing offset, also normalized 0 to 1
swing :: ScoreTime -> RealTime
swing = Double -> RealTime
RealTime.seconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Eq a, Fractional a) => a -> a -> a -> a
Num.normalize (-Double
1) Double
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Floating a => a -> a
sin forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
*forall a. Floating a => a
pi)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale (-Double
0.5) Double
1.5 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScoreTime -> Double
ScoreTime.to_double

-- * cf-clamp

c_cf_clamp :: Derive.ValCall
c_cf_clamp :: ValCall
c_cf_clamp = forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call CallName
"cf-clamp" Tags
Tags.control_function
    Doc
"Clamp the output of a control function to the given range."
    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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"cf" Doc
"Control function."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"low" (Double
0 :: Double) Doc
"Low value."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"high" (Double
1 :: Double) Doc
"High value."
    ) forall a b. (a -> b) -> a -> b
$ \(CFunction
cf, Double
low, Double
high) PassedArgs Tagged
_args ->
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> (Double -> Double) -> CFunction -> CFunction
cf_compose (Text
"cf-clamp(" forall a. Semigroup a => a -> a -> a
<> CFunction -> Text
DeriveT.cf_name CFunction
cf forall a. Semigroup a => a -> a -> a
<> Text
")")
            (forall a. Ord a => a -> a -> a -> a
Num.clamp Double
low Double
high) CFunction
cf

cf_compose :: Text -> (Signal.Y -> Signal.Y) -> DeriveT.CFunction
    -> DeriveT.CFunction
cf_compose :: Text -> (Double -> Double) -> CFunction -> CFunction
cf_compose Text
name Double -> Double
f CFunction
cf = DeriveT.CFunction
    { cf_name :: Text
cf_name = Text
name
    , cf_signal :: TypedSignal
cf_signal = CFunction -> TypedSignal
DeriveT.cf_signal CFunction
cf
    , cf_function :: Dynamic -> Control -> RealTime -> Double
cf_function = \Dynamic
cf_dyn Control
c -> Double -> Double
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFunction -> Dynamic -> Control -> RealTime -> Double
DeriveT.cf_function CFunction
cf Dynamic
cf_dyn Control
c
    }

-- * curve interpolators

curves :: [(Doc.Doc, ControlUtil.CurveD)]
curves :: [(Doc, CurveD)]
curves =
    [ ( Doc
"Jump to the destination at 0.5."
      , forall arg. Text -> Parser arg -> (arg -> Curve) -> CurveD
ControlUtil.CurveD Text
"jump" (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) forall a b. (a -> b) -> a -> b
$
        \() -> (Double -> Double) -> Curve
ControlUtil.Function forall a b. (a -> b) -> a -> b
$ \Double
n -> if Double
n forall a. Ord a => a -> a -> Bool
< Double
0.5 then Double
0 else Double
1
      )
    , (Doc
"No interpolation.", forall arg. Text -> Parser arg -> (arg -> Curve) -> CurveD
ControlUtil.CurveD Text
"const" (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) forall a b. (a -> b) -> a -> b
$
        \() -> (Double -> Double) -> Curve
ControlUtil.Function (forall a b. a -> b -> a
const Double
0))
    ]

-- * DeriveT.Dynamic

dyn_seed :: DeriveT.Dynamic -> Double
dyn_seed :: Dynamic -> Double
dyn_seed Dynamic
cf_dyn = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Dynamic -> Int
DeriveT.dyn_event_serial Dynamic
cf_dyn) forall a. Num a => a -> a -> a
+ Dynamic -> Double
seed Dynamic
cf_dyn
    where seed :: Dynamic -> Double
seed = forall a. a -> Maybe a -> a
fromMaybe Double
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typecheck a => Text -> Environ -> Maybe a
Env.maybe_val Text
EnvKey.seed forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dynamic -> Environ
DeriveT.dyn_environ

real :: DeriveT.Dynamic -> ScoreTime -> RealTime
real :: Dynamic -> ScoreTime -> RealTime
real = Warp -> ScoreTime -> RealTime
Warp.warp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dynamic -> Warp
DeriveT.dyn_warp

score :: DeriveT.Dynamic -> RealTime -> ScoreTime
score :: Dynamic -> RealTime -> ScoreTime
score = Warp -> RealTime -> ScoreTime
Warp.unwarp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dynamic -> Warp
DeriveT.dyn_warp

-- ** ControlRef

to_function :: DeriveT.Dynamic -> Signal.Y -> Ref -> ScoreT.Function
to_function :: Dynamic -> Double -> Ref -> RealTime -> Double
to_function Dynamic
cf_dyn Double
deflt =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> b -> a
const Double
deflt) forall a. Typed a -> a
ScoreT.val_of forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dynamic -> Ref -> Maybe TypedFunction
lookup_function Dynamic
cf_dyn

-- | TODO duplicated with Typecheck.lookup_function except it
-- can't be in Deriver.
lookup_function :: DeriveT.Dynamic -> Ref -> Maybe ScoreT.TypedFunction
lookup_function :: Dynamic -> Ref -> Maybe TypedFunction
lookup_function Dynamic
_ (Right Typed Double
ty) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typed Double
ty
lookup_function Dynamic
cf_dyn (Left (DeriveT.Ref Control
control Maybe TypedSignal
deflt)) =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe TypedFunction
deflt_f Val -> Maybe TypedFunction
get forall a b. (a -> b) -> a -> b
$ Text -> Environ -> Maybe Val
DeriveT.lookup (Control -> Text
ScoreT.control_name Control
control) forall a b. (a -> b) -> a -> b
$
        Dynamic -> Environ
DeriveT.dyn_environ Dynamic
cf_dyn
    where
    deflt_f :: Maybe TypedFunction
deflt_f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} (kind :: k). Signal kind -> RealTime -> Double
Signal.at forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TypedSignal
deflt
    get :: Val -> Maybe TypedFunction
get = Dynamic -> Val -> Maybe TypedFunction
val_to_function Dynamic
cf_dyn

val_to_function :: DeriveT.Dynamic -> DeriveT.Val -> Maybe ScoreT.TypedFunction
val_to_function :: Dynamic -> Val -> Maybe TypedFunction
val_to_function Dynamic
cf_dyn = \case
    DeriveT.VSignal TypedSignal
sig -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). Signal kind -> RealTime -> Double
Signal.at forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypedSignal
sig
    DeriveT.VControlRef ControlRef
ref -> Dynamic -> Ref -> Maybe TypedFunction
lookup_function Dynamic
cf_dyn (forall a b. a -> Either a b
Left ControlRef
ref)
    DeriveT.VCFunction CFunction
cf -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Dynamic -> CFunction -> TypedFunction
DeriveT.call_cfunction Dynamic
cf_dyn CFunction
cf
    Val
_ -> forall a. Maybe a
Nothing


-- * misc

val_call :: Typecheck.ToVal a => Derive.CallName -> Tags.Tags -> Doc.Doc
    -> Derive.WithArgDoc (Derive.PassedArgs Derive.Tagged -> Derive.Deriver a)
    -> Derive.ValCall
val_call :: forall a.
ToVal a =>
CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
val_call = forall a.
ToVal a =>
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs Tagged -> Deriver a)
-> ValCall
Derive.val_call Module
Module.prelude