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

-- | Export a 'synth' with all the supported patches.
module Synth.Faust.PatchDb (synth, warnings) where
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified System.IO.Unsafe as Unsafe

import qualified Util.Doc as Doc
import qualified Util.Maps as Maps
import qualified Util.Seq as Seq

import qualified Cmd.Instrument.ImInst as ImInst
import qualified Derive.Instrument.DUtil as DUtil
import qualified Derive.ScoreT as ScoreT
import qualified Instrument.InstT as InstT
import qualified Perform.Im.Patch as Patch
import qualified Perform.Pitch as Pitch
import qualified Synth.Faust.Code as Code
import qualified Synth.Faust.InstrumentC as InstrumentC
import qualified Synth.Faust.Preview as Preview
import qualified Synth.Shared.Config as Config
import qualified Synth.Shared.Control as Control
import qualified Synth.Shared.Thru as Thru
import qualified Synth.Shared.Signal as Signal

import           Global


synth :: ImInst.Synth
synth :: Synth
synth = Error -> Error -> [(Error, Patch)] -> Synth
ImInst.synth Error
Config.faustName Error
"音 faust synthesizer" [(Error, Patch)]
patches

patches :: [(InstT.Name, ImInst.Patch)]
warnings :: [Text]
([Error]
warnings, [(Error, Patch)]
patches) = IO ([Error], [(Error, Patch)]) -> ([Error], [(Error, Patch)])
forall a. IO a -> a
Unsafe.unsafePerformIO (IO ([Error], [(Error, Patch)]) -> ([Error], [(Error, Patch)]))
-> IO ([Error], [(Error, Patch)]) -> ([Error], [(Error, Patch)])
forall a b. (a -> b) -> a -> b
$ do
    FilePath
imDir <- Config -> FilePath
Config.imDir (Config -> FilePath) -> IO Config -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Config
Config.getConfig
    -- These are in IO, but should be safe, because they are just reading
    -- static data.  In fact the FFI functions could probably omit the IO.
    Map Error (Either Error Patch)
pmap <- IO (Map Error (Either Error Patch))
InstrumentC.getPatches
    let errors :: [Error]
errors =
            [ Error
"faust/" Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Error
name Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Error
": " Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Error
err
            | (Error
name, Left Error
err) <- Map Error (Either Error Patch) -> [(Error, Either Error Patch)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Error (Either Error Patch)
pmap
            ] [Error] -> [Error] -> [Error]
forall a. [a] -> [a] -> [a]
++
            [ Error
"faust: patch code with no patch: " Error -> Error -> Error
forall a. Semigroup a => a -> a -> a
<> Error
name
            | (Error
name, Seq.Second Code
_) <- Map Error (Either Error Patch)
-> Map Error Code -> [(Error, Paired (Either Error Patch) Code)]
forall k v1 v2.
Ord k =>
Map k v1 -> Map k v2 -> [(k, Paired v1 v2)]
Maps.pairs Map Error (Either Error Patch)
pmap Map Error Code
patchCode
            ]
    ([Error], [(Error, Patch)]) -> IO ([Error], [(Error, Patch)])
forall (m :: * -> *) a. Monad m => a -> m a
return (([Error], [(Error, Patch)]) -> IO ([Error], [(Error, Patch)]))
-> ([Error], [(Error, Patch)]) -> IO ([Error], [(Error, Patch)])
forall a b. (a -> b) -> a -> b
$ ([Error]
errors,)
        [ (Error
name, FilePath -> Patch -> Patch
makePatch FilePath
imDir Patch
patch)
        | (Error
name, Right Patch
patch) <- Map Error (Either Error Patch) -> [(Error, Either Error Patch)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Error (Either Error Patch)
pmap
        ]

patchCode :: Map Text ImInst.Code
patchCode :: Map Error Code
patchCode = [(Error, Code)] -> Map Error Code
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Error
"tambura8", Code
tambura), (Error
"tambura4", Code
tambura)
    ]
    where
    tambura :: Code
tambura = [Call Note] -> Code
ImInst.note_calls
        [ Symbol -> Transformer Note -> Call Note
forall d. Symbol -> Transformer d -> Call d
ImInst.transformer Symbol
"terminate" (Control -> RealTime -> Transformer Note
Code.note_terminate Control
"decay" RealTime
0.01)
        ]

makePatch :: FilePath -> InstrumentC.Patch -> ImInst.Patch
makePatch :: FilePath -> Patch -> Patch
makePatch FilePath
imDir Patch
patch =
    Lens Patch Doc
ImInst.doc Lens Patch Doc -> Doc -> Patch -> Patch
forall f a. Lens f a -> a -> f -> f
#= Error -> Doc
Doc.Doc (Patch -> Error
forall ptr cptr. PatchT ptr cptr -> Error
InstrumentC._doc Patch
patch) (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$
    Bool -> [Control] -> Patch -> Patch
code Bool
constantPitch [Control]
constantControls (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$
    Patch -> Patch
ImInst.make_patch (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$ Patch
Patch.patch
        { patch_controls :: Map Control Error
Patch.patch_controls = (ControlConfig -> Error
forall a. Pretty a => a -> Error
pretty (ControlConfig -> Error)
-> Map Control ControlConfig -> Map Control Error
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Control ControlConfig
controls) Map Control Error -> Map Control Error -> Map Control Error
forall a. Semigroup a => a -> a -> a
<> Map Control Error
standardControls
        , patch_elements :: Set Error
Patch.patch_elements = [Error] -> Set Error
forall a. Ord a => [a] -> Set a
Set.fromList ([Error] -> Set Error) -> [Error] -> Set Error
forall a b. (a -> b) -> a -> b
$ (Error -> Bool) -> [Error] -> [Error]
forall a. (a -> Bool) -> [a] -> [a]
filter (Error -> Error -> Bool
forall a. Eq a => a -> a -> Bool
/=Error
"") ([Error] -> [Error]) -> [Error] -> [Error]
forall a b. (a -> b) -> a -> b
$ ((Error, Control) -> Error) -> [(Error, Control)] -> [Error]
forall a b. (a -> b) -> [a] -> [b]
map (Error, Control) -> Error
forall a b. (a, b) -> a
fst ([(Error, Control)] -> [Error]) -> [(Error, Control)] -> [Error]
forall a b. (a -> b) -> a -> b
$
            Map (Error, Control) ((), ControlConfig) -> [(Error, Control)]
forall k a. Map k a -> [k]
Map.keys (Map (Error, Control) ((), ControlConfig) -> [(Error, Control)])
-> Map (Error, Control) ((), ControlConfig) -> [(Error, Control)]
forall a b. (a -> b) -> a -> b
$ Patch -> Map (Error, Control) ((), ControlConfig)
forall ptr cptr.
PatchT ptr cptr -> Map (Error, Control) (cptr, ControlConfig)
InstrumentC._controls Patch
patch
        }
    where
    constantControls :: [Control]
constantControls = ((Control, ControlConfig) -> Control)
-> [(Control, ControlConfig)] -> [Control]
forall a b. (a -> b) -> [a] -> [b]
map (Control, ControlConfig) -> Control
forall a b. (a, b) -> a
fst ([(Control, ControlConfig)] -> [Control])
-> [(Control, ControlConfig)] -> [Control]
forall a b. (a -> b) -> a -> b
$ ((Control, ControlConfig) -> Bool)
-> [(Control, ControlConfig)] -> [(Control, ControlConfig)]
forall a. (a -> Bool) -> [a] -> [a]
filter (ControlConfig -> Bool
InstrumentC._constant (ControlConfig -> Bool)
-> ((Control, ControlConfig) -> ControlConfig)
-> (Control, ControlConfig)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Control, ControlConfig) -> ControlConfig
forall a b. (a, b) -> b
snd) ([(Control, ControlConfig)] -> [(Control, ControlConfig)])
-> [(Control, ControlConfig)] -> [(Control, ControlConfig)]
forall a b. (a -> b) -> a -> b
$
        ((Control, ControlConfig) -> Bool)
-> [(Control, ControlConfig)] -> [(Control, ControlConfig)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Control -> Control -> Bool
forall a. Eq a => a -> a -> Bool
/=Control
Control.pitch) (Control -> Bool)
-> ((Control, ControlConfig) -> Control)
-> (Control, ControlConfig)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Control, ControlConfig) -> Control
forall a b. (a, b) -> a
fst) ([(Control, ControlConfig)] -> [(Control, ControlConfig)])
-> [(Control, ControlConfig)] -> [(Control, ControlConfig)]
forall a b. (a -> b) -> a -> b
$ Map Control ControlConfig -> [(Control, ControlConfig)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Control ControlConfig
controls
    constantPitch :: Bool
constantPitch = Bool -> (ControlConfig -> Bool) -> Maybe ControlConfig -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ControlConfig -> Bool
InstrumentC._constant (Maybe ControlConfig -> Bool) -> Maybe ControlConfig -> Bool
forall a b. (a -> b) -> a -> b
$
        Control -> Map Control ControlConfig -> Maybe ControlConfig
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
Control.pitch Map Control ControlConfig
controls
    controls :: Map Control ControlConfig
controls = Patch -> Map Control ControlConfig
forall ptr cptr. PatchT ptr cptr -> Map Control ControlConfig
InstrumentC.imControls Patch
patch
    code :: Bool -> [Control] -> Patch -> Patch
code Bool
constantPitch [Control]
constantControls = (Lens Patch Code
ImInst.code #=) (Code -> Patch -> Patch) -> Code -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$ [Code] -> Code
forall a. Monoid a => [a] -> a
mconcat
        [ if Bool
constantPitch Bool -> Bool -> Bool
|| Bool -> Bool
not ([Control] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Control]
constantControls)
            then Generator Note -> Code
ImInst.null_call (Generator Note -> Code) -> Generator Note -> Code
forall a b. (a -> b) -> a -> b
$
                Bool -> Set Control -> Generator Note
DUtil.constant_controls Bool
constantPitch
                    ([Control] -> Set Control
forall a. Ord a => [a] -> Set a
Set.fromList ((Control -> Control) -> [Control] -> [Control]
forall a b. (a -> b) -> [a] -> [b]
map Control -> Control
control [Control]
constantControls))
            else Code
forall a. Monoid a => a
mempty
        , Map NoteNumber FilePath -> Code
thruCode Map NoteNumber FilePath
pitchToSample
        , case Patch -> Maybe Error
forall ptr cptr. PatchT ptr cptr -> Maybe Error
InstrumentC._elementFrom Patch
patch of
            Maybe Error
Nothing -> Code
forall a. Monoid a => a
mempty
            Just Error
elementFrom -> InstrumentPostproc -> Code
ImInst.postproc (InstrumentPostproc -> Code) -> InstrumentPostproc -> Code
forall a b. (a -> b) -> a -> b
$
                Error -> InstrumentPostproc
DUtil.element_from_id Error
elementFrom
        , Code -> Error -> Map Error Code -> Code
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Code
forall a. Monoid a => a
mempty (Patch -> Error
forall ptr cptr. PatchT ptr cptr -> Error
InstrumentC._name Patch
patch) Map Error Code
patchCode
        ]
    pitchToSample :: Map NoteNumber FilePath
pitchToSample = FilePath -> Error -> Map NoteNumber FilePath
Preview.pitchToSample FilePath
imDir (Patch -> Error
forall ptr cptr. PatchT ptr cptr -> Error
InstrumentC._name Patch
patch)

control :: Control.Control -> ScoreT.Control
control :: Control -> Control
control (Control.Control Error
c) = Error -> Control
ScoreT.Control Error
c

standardControls :: Map Control.Control Text
standardControls :: Map Control Error
standardControls = [(Control, Error)] -> Map Control Error
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Control
Control.volume, Error
"Low level volume, in dB.")
    -- , (Control.pan, "Pan, where -1 is left, and 1 is right.")
    ]
    -- All instruments put dyn in the gate signal.
    Map Control Error -> Map Control Error -> Map Control Error
forall a. Semigroup a => a -> a -> a
<> Map Control Error
Control.supportDyn

-- * thru

thruCode :: Map Pitch.NoteNumber FilePath -> ImInst.Code
thruCode :: Map NoteNumber FilePath -> Code
thruCode = ThruFunction -> Code
ImInst.thru (ThruFunction -> Code)
-> (Map NoteNumber FilePath -> ThruFunction)
-> Map NoteNumber FilePath
-> Code
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map NoteNumber FilePath -> ThruFunction
thruFunction

-- This would be used for attribute-oriented instruments for a custom CUtil
-- call.
-- imThruFunction :: Map Pitch.NoteNumber FilePath -> CUtil.Thru
-- imThruFunction = CUtil.ImThru . thruFunction

thruFunction :: Map Pitch.NoteNumber FilePath -> Thru.ThruFunction
thruFunction :: Map NoteNumber FilePath -> ThruFunction
thruFunction Map NoteNumber FilePath
pitchToSample = ([Play] -> Message) -> Either Error [Play] -> Either Error Message
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Play] -> Message
Thru.Plays (Either Error [Play] -> Either Error Message)
-> ([Note] -> Either Error [Play]) -> ThruFunction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Note -> Either Error Play) -> [Note] -> Either Error [Play]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Note -> Either Error Play
forall {a}. IsString a => Note -> Either a Play
note
    where
    note :: Note -> Either a Play
note (Thru.Note { _pitch :: Note -> NoteNumber
_pitch = NoteNumber
pitch }) =
        case NoteNumber
-> Map NoteNumber FilePath -> Maybe (NoteNumber, FilePath)
forall k v. (Ord k, Num k) => k -> Map k v -> Maybe (k, v)
Maps.lookupClosest NoteNumber
pitch Map NoteNumber FilePath
pitchToSample of
            Maybe (NoteNumber, FilePath)
Nothing -> a -> Either a Play
forall a b. a -> Either a b
Left a
"no samples"
            Just (NoteNumber
sampleNn, FilePath
sample) -> Play -> Either a Play
forall a b. b -> Either a b
Right (Play -> Either a Play) -> Play -> Either a Play
forall a b. (a -> b) -> a -> b
$ Thru.Play
                { _sample :: FilePath
_sample = FilePath
sample
                , _offset :: Frames
_offset = Frames
0
                , _ratio :: Y
_ratio = NoteNumber -> NoteNumber -> Y
pitchToRatio NoteNumber
sampleNn NoteNumber
pitch
                -- I could use velocity, but I don't render at different
                -- dynamics so let's not give that impression.
                , _volume :: Y
_volume = Y
1
                }

-- | From Sampler.Sample
pitchToRatio :: Pitch.NoteNumber -> Pitch.NoteNumber -> Signal.Y
pitchToRatio :: NoteNumber -> NoteNumber -> Y
pitchToRatio NoteNumber
sampleNn NoteNumber
nn = NoteNumber -> Y
Pitch.nn_to_hz NoteNumber
sampleNn Y -> Y -> Y
forall a. Fractional a => a -> a -> a
/ NoteNumber -> Y
Pitch.nn_to_hz NoteNumber
nn