-- 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 for 箏.
module Derive.C.China.Zheng (library) where
import qualified Derive.Args as Args
import qualified Derive.C.Idiom.String as String
import qualified Derive.C.Prelude.Trill as Trill
import qualified Derive.Call as Call
import qualified Derive.Call.ControlUtil as ControlUtil
import qualified Derive.Call.Ly as Ly
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Sub as Sub
import qualified Derive.Call.Tags as Tags
import qualified Derive.Derive as Derive
import qualified Derive.DeriveT as DeriveT
import qualified Derive.Expr as Expr
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Sig as Sig
import qualified Derive.Typecheck as Typecheck

import qualified Perform.Lilypond.Constants as Constants


module_ :: Module.Module
module_ :: Module
module_ = Module
"china" forall a. Semigroup a => a -> a -> a
<> Module
"zheng"

library :: Library.Library
library :: Library
library = forall a. Monoid a => [a] -> a
mconcat
    [ forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators forall a b. (a -> b) -> a -> b
$
        [ (Symbol
"gliss-a", forall f. Module -> Call f -> Call f
Derive.set_module Module
module_ Generator Note
String.c_gliss_absolute)
        , (Symbol
"gliss", forall f. Module -> Call f -> Call f
Derive.set_module Module
module_ Generator Note
String.c_gliss)
        ] forall a. [a] -> [a] -> [a]
++ forall call. (Maybe Direction -> call) -> [(Symbol, call)]
trill_variations Maybe Direction -> Generator Note
c_note_trill
    , forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
        [ (Symbol
"bent-string", forall f. Module -> Call f -> Call f
Derive.set_module Module
module_ Transformer Note
String.c_bent_string)
        ]
    , forall call.
ToLibrary (Generator call) =>
[(Symbol, Generator call)] -> Library
Library.generators forall a b. (a -> b) -> a -> b
$ forall call. (Maybe Direction -> call) -> [(Symbol, call)]
trill_variations Maybe Direction -> Generator Pitch
c_pitch_trill
    ]

trill_variations :: (Maybe Trill.Direction -> call) -> [(Expr.Symbol, call)]
trill_variations :: forall call. (Maybe Direction -> call) -> [(Symbol, call)]
trill_variations Maybe Direction -> call
make =
    [ (Ly -> Symbol
Expr.Symbol forall a b. (a -> b) -> a -> b
$ Ly
"tr" forall a. Semigroup a => a -> a -> a
<> Maybe Direction -> Ly
Trill.direction_affix Maybe Direction
end, Maybe Direction -> call
make Maybe Direction
end)
    | Maybe Direction
end <- [Maybe Direction]
dirs
    ]
    where dirs :: [Maybe Direction]
dirs = [forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just Direction
Trill.High, forall a. a -> Maybe a
Just Direction
Trill.Low]

-- * trill

c_note_trill :: Maybe Trill.Direction -> Derive.Generator Derive.Note
c_note_trill :: Maybe Direction -> Generator Note
c_note_trill Maybe Direction
start_dir = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
module_ CallName
"tr" Tags
Tags.ly
    Doc
"A trill with smooth transitions."
    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
<$> Parser NnTransposeFunctionT
neighbor_arg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser RealTimeFunctionT
speed_arg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Duration
Trill.hold_env
    ) forall a b. (a -> b) -> a -> b
$ \(NnTransposeFunctionT
neighbor, RealTimeFunctionT
speed, Duration
hold) -> forall d.
(PassedArgs d -> NoteDeriver) -> PassedArgs d -> NoteDeriver
Sub.inverting forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
args ->
    forall d. Code -> PassedArgs d -> NoteDeriver -> NoteDeriver
Ly.note_code (Distribution -> Position CodePosition
Ly.append Distribution
Constants.First, Ly
"\\trill") PassedArgs Note
args forall a b. (a -> b) -> a -> b
$ do
        Pitch
pitch <- RealTime -> Deriver State Error Pitch
Call.get_pitch forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Note
args
        Pitch
sig <- forall a.
Maybe Direction
-> Pitch
-> NnTransposeFunctionT
-> RealTimeFunctionT
-> Duration
-> PassedArgs a
-> Deriver Pitch
trill_signal Maybe Direction
start_dir Pitch
pitch NnTransposeFunctionT
neighbor RealTimeFunctionT
speed Duration
hold PassedArgs Note
args
        forall a. Pitch -> Deriver a -> Deriver a
Derive.with_pitch Pitch
sig forall a b. (a -> b) -> a -> b
$ forall d. PassedArgs d -> NoteDeriver
Call.placed_note PassedArgs Note
args

c_pitch_trill :: Maybe Trill.Direction -> Derive.Generator Derive.Pitch
c_pitch_trill :: Maybe Direction -> Generator Pitch
c_pitch_trill Maybe Direction
start_dir = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (PassedArgs d -> Deriver d)
-> Generator d
Derive.generator1 Module
module_ CallName
"tr" forall a. Monoid a => a
mempty
    Doc
"A trill with smooth transitions."
    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
"pitch" Doc
"Base pitch."
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser NnTransposeFunctionT
neighbor_arg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser RealTimeFunctionT
speed_arg forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Duration
Trill.hold_env
    ) forall a b. (a -> b) -> a -> b
$ \(Pitch
pitch, NnTransposeFunctionT
neighbor, RealTimeFunctionT
speed, Duration
hold) PassedArgs Pitch
args ->
        forall a.
Maybe Direction
-> Pitch
-> NnTransposeFunctionT
-> RealTimeFunctionT
-> Duration
-> PassedArgs a
-> Deriver Pitch
trill_signal Maybe Direction
start_dir Pitch
pitch NnTransposeFunctionT
neighbor RealTimeFunctionT
speed Duration
hold PassedArgs Pitch
args

trill_signal :: Maybe Trill.Direction -> PSignal.Pitch
    -> Typecheck.NnTransposeFunctionT -> Typecheck.RealTimeFunctionT
    -> DeriveT.Duration -> Derive.PassedArgs a
    -> Derive.Deriver PSignal.PSignal
trill_signal :: forall a.
Maybe Direction
-> Pitch
-> NnTransposeFunctionT
-> RealTimeFunctionT
-> Duration
-> PassedArgs a
-> Deriver Pitch
trill_signal Maybe Direction
start_dir Pitch
pitch (Typecheck.NnTransposeFunctionT TransposeT
ttype Function
neighbor)
        RealTimeFunctionT
speed Duration
hold PassedArgs a
args = do
    Control
transpose <- Config
-> Curve -> (ScoreTime, ScoreTime) -> Function -> Deriver Control
Trill.get_trill_control_smooth Config
config Curve
curve
        (forall a. PassedArgs a -> (ScoreTime, ScoreTime)
Args.range_or_next PassedArgs a
args) Function
neighbor
    RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs a
args
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Control -> Typed Control -> Pitch -> Pitch
PSignal.apply_control (TransposeT -> Control
Typecheck.transpose_control TransposeT
ttype)
        (forall a. a -> Typed a
ScoreT.untyped Control
transpose) (RealTime -> Pitch -> Pitch
PSignal.from_sample RealTime
start Pitch
pitch)
    where
    config :: Config
config = Trill.Config
        { _speed :: RealTimeFunctionT
_speed = RealTimeFunctionT
speed
        , _start_dir :: Maybe Direction
_start_dir = Maybe Direction
start_dir
        , _end_dir :: Maybe Direction
_end_dir = forall a. Maybe a
Nothing
        , _hold :: Duration
_hold = Duration
hold
        , _adjust :: Adjust
_adjust = Adjust
Trill.Stretch
        , _bias :: Double
_bias = Double
0
        , _include_end :: Bool
_include_end = Bool
True
        }
    curve :: Curve
curve = Curve
ControlUtil.Linear
    -- A sigmoid curve looks nice, but as far as I can tell, it sounds the same
    -- as linear, and linear should be cheaper.
    -- curve = ControlUtil.Function $ ControlUtil.sigmoid 0.5 0.5

neighbor_arg :: Sig.Parser Typecheck.NnTransposeFunctionT
neighbor_arg :: Parser NnTransposeFunctionT
neighbor_arg = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"neighbor" (Int
1 :: Int)
    Doc
"Alternate with a pitch at this interval."

speed_arg :: Sig.Parser Typecheck.RealTimeFunctionT
speed_arg :: Parser RealTimeFunctionT
speed_arg = forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"speed" (Int
20 :: Int) Doc
"Alternate pitches at this speed."