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

-- | Calls that configure other calls.
module Derive.C.Prelude.Config (library) where
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Util.Lists as Lists
import qualified Util.Maps as Maps
import qualified Derive.Args as Args
import qualified Derive.Call.Make as Make
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Post as Post
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.Flags as Flags
import qualified Derive.Library as Library
import qualified Derive.PSignal as PSignal
import qualified Derive.Score as Score
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Sig as Sig
import qualified Derive.Stream as Stream
import qualified Derive.Typecheck as Typecheck

import qualified Perform.Pitch as Pitch
import qualified Perform.Signal as Signal
import qualified Synth.Shared.Note as Note

import           Global


library :: Library.Library
library :: Library
library = forall a. Monoid a => [a] -> a
mconcat
    [ (forall d. CallableExpr d => [(Symbol, Transformer d)]) -> Library
Library.poly_transformers [(Symbol
"h", forall d. Taggable d => Transformer d
c_hold)]
    , forall call.
ToLibrary (Transformer call) =>
[(Symbol, Transformer call)] -> Library
Library.transformers
        [ (Symbol
"add-flag", Transformer Note
c_add_flag)
        , (Symbol
"infer-dur", Transformer Note
c_infer_dur)
        , (Symbol
"initialize", Transformer Note
c_initialize)
        ]
    ]

c_add_flag :: Derive.Transformer Derive.Note
c_add_flag :: Transformer Note
c_add_flag = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"add-flag" Tags
Tags.postproc
    Doc
"Add the given flags to transformed events.\
    \ Mostly for debugging and testing."
    forall a b. (a -> b) -> a -> b
$ forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt (forall a. Typecheck a => ArgName -> Doc -> Parser (NonEmpty a)
Sig.many1 ArgName
"flag" Doc
"Add these flags.") forall a b. (a -> b) -> a -> b
$ \NonEmpty Text
flags PassedArgs Note
_args ->
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ forall a b. (a -> b) -> a -> b
$ Flags -> Note -> Note
Score.add_flags forall a b. (a -> b) -> a -> b
$ forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap Text -> Flags
Flags.flag forall a b. (a -> b) -> a -> b
$
            forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Text
flags

c_hold :: Derive.Taggable d => Derive.Transformer d
c_hold :: forall d. Taggable d => Transformer d
c_hold = forall val d a.
(ToVal val, Taggable d) =>
Module -> Text -> Doc -> Parser a -> (a -> val) -> Transformer d
Make.environ Module
Module.prelude Text
EnvKey.hold Doc
"'Derive.EnvKey.hold'"
    (forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> deflt -> Doc -> Parser a
Sig.defaulted ArgName
"time" (RealTime -> DefaultReal
Typecheck.real RealTime
0.25) Doc
"Hold this long.")
    DefaultReal -> Duration
Typecheck._real

c_infer_dur :: Derive.Transformer Derive.Note
c_infer_dur :: Transformer Note
c_infer_dur = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"infer-dur" Tags
Tags.postproc
    Doc
"Add 'Derive.Flags.infer_duration' to the events."
    forall a b. (a -> b) -> a -> b
$ forall y d.
Taggable y =>
Transformer y d -> WithArgDoc (Transformer y d)
Sig.call0t forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
_args ->
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> Stream a -> Stream b
Post.emap1_ forall a b. (a -> b) -> a -> b
$ Flags -> Note -> Note
Score.add_flags Flags
Flags.infer_duration

-- * initialize

c_initialize :: Derive.Transformer Derive.Note
c_initialize :: Transformer Note
c_initialize = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (TransformerF d)
-> Transformer d
Derive.transformer Module
Module.prelude CallName
"initialize" forall a. Monoid a => a
mempty
    Doc
"Emit initialization controls for im instruments." forall a b. (a -> b) -> a -> b
$
    forall y a d.
Taggable y =>
Parser a -> (a -> Transformer y d) -> WithArgDoc (Transformer y d)
Sig.callt ((,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Typecheck a => ArgName -> Doc -> Parser a
Sig.required ArgName
"inst" Doc
"Instrument to initialize."
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a b.
(Typecheck a, Typecheck b) =>
ArgName -> Doc -> Parser [(a, b)]
Sig.many_pairs ArgName
"control,val" Doc
"(control, val) pairs.\
            \ If the val is a list, expect the instrument to have that many\
            \ elements, and set the control for each element."
    ) forall a b. (a -> b) -> a -> b
$ \(Instrument
inst, [(Control, [Either Double Pitch])]
pairs) PassedArgs Note
args Deriver State Error (Stream Note)
deriver -> do
        Set Text
elements <- Instrument -> Set Text
Derive.inst_elements forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Instrument -> Deriver (Instrument, Instrument)
Derive.get_instrument Instrument
inst
        RealTime
start <- forall a. PassedArgs a -> Deriver RealTime
Args.real_start PassedArgs Note
args
        -- [(_, [Either _ Pitch])] -> [(_, [Either _ Transposed])]
        [(Control, [Either Double Transposed])]
pairs <- (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse)
            (RealTime -> Pitch -> Deriver State Error Transposed
Derive.resolve_pitch RealTime
start) [(Control, [Either Double Pitch])]
pairs
        Map Text (Map Control Double)
element_controls <- forall err a.
HasCallStack =>
(err -> Text) -> Either err a -> Deriver a
Derive.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$
            [Text]
-> [(Control, [Either Double Transposed])]
-> Either Text (Map Text (Map Control Double))
parse_pairs (forall a. Set a -> [a]
Set.toAscList Set Text
elements) [(Control, [Either Double Transposed])]
pairs
        let notes :: [Note]
notes = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Instrument -> Text -> Map Control Double -> Note
dummy_note Instrument
inst))
                (forall k a. Map k a -> [(k, a)]
Map.toList Map Text (Map Control Double)
element_controls)
        (forall a. [a] -> Stream a
Stream.from_events [Note]
notes <>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Deriver State Error (Stream Note)
deriver

dummy_note :: ScoreT.Instrument -> Note.Element -> Map ScoreT.Control Double
    -> Score.Event
dummy_note :: Instrument -> Text -> Map Control Double -> Note
dummy_note Instrument
inst Text
element Map Control Double
controls = Note
Score.empty_event
    { event_pitch :: PSignal
Score.event_pitch = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
pitch Map Control Double
controls of
        Maybe Double
Nothing -> forall a. Monoid a => a
mempty
        Just Double
nn -> Pitch -> PSignal
PSignal.constant forall a b. (a -> b) -> a -> b
$ NoteNumber -> Pitch
PSignal.nn_pitch (forall a. Real a => a -> NoteNumber
Pitch.nn Double
nn)
    , event_text :: Text
Score.event_text = Text
"faust initialize"
    , event_instrument :: Instrument
Score.event_instrument = Instrument
inst
    , event_environ :: Environ
Score.event_environ =
        ([(Text, Val)] -> Environ
Env.from_list [(Text
EnvKey.element, forall a. ToVal a => a -> Val
Typecheck.to_val Text
element)] <>) forall a b. (a -> b) -> a -> b
$
        ControlMap -> Environ
Env.from_controls forall a b. (a -> b) -> a -> b
$ forall {k} {kind :: k}. Double -> Typed (Signal kind)
make_val forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Control
Controls.dynamic Double
0 (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Control
pitch Map Control Double
controls)
    }
    where
    pitch :: Control
pitch = Control
"pitch"
    make_val :: Double -> Typed (Signal kind)
make_val = forall a. a -> Typed a
ScoreT.untyped forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (kind :: k). Double -> Signal kind
Signal.constant

parse_pairs :: [Note.Element]
    -> [(ScoreT.Control, [Either Double PSignal.Transposed])]
    -> Either Text (Map Note.Element (Map ScoreT.Control Double))
parse_pairs :: [Text]
-> [(Control, [Either Double Transposed])]
-> Either Text (Map Text (Map Control Double))
parse_pairs [Text]
elements =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k [a]
Maps.multimap) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM forall {t}.
(t, [Either Double Transposed])
-> Either Text [(Text, (t, Double))]
parse
    where
    parse :: (t, [Either Double Transposed])
-> Either Text [(Text, (t, Double))]
parse (t
_, []) = forall (m :: * -> *) a. Monad m => a -> m a
return []
    parse (t
control, [Either Double Transposed
val]) = do
        Double
val <- Either Double Transposed -> Either Text Double
resolve Either Double Transposed
val
        forall (m :: * -> *) a. Monad m => a -> m a
return [(forall a. a -> Maybe a -> a
fromMaybe Text
"" (forall a. [a] -> Maybe a
Lists.head [Text]
elements), (t
control, Double
val))]
    parse (t
control, [Either Double Transposed]
vals)
        | forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Double Transposed]
vals forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
elements = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> Text
showt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either Double Transposed]
vals)
            forall a. Semigroup a => a -> a -> a
<> Text
" values for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
elements) forall a. Semigroup a => a -> a -> a
<> Text
" elements: "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [Either Double Transposed]
vals forall a. Semigroup a => a -> a -> a
<> Text
" vs. " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [Text]
elements
        | Bool
otherwise = do
            [Double]
vals <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Either Double Transposed -> Either Text Double
resolve [Either Double Transposed]
vals
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
elements (forall a b. (a -> b) -> [a] -> [b]
map (t
control,) [Double]
vals)
    resolve :: Either Double Transposed -> Either Text Double
resolve (Left Double
nn) = forall a b. b -> Either a b
Right Double
nn
    resolve (Right Transposed
p) = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a. Pretty a => a -> Text
pretty NoteNumber -> Double
Pitch.nn_to_double forall a b. (a -> b) -> a -> b
$ Transposed -> Either PitchError NoteNumber
DeriveT.pitch_nn Transposed
p