-- 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.Lists as Lists

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) = forall a. IO a -> a
Unsafe.unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    FilePath
imDir <- Config -> FilePath
Config.imDir 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/" forall a. Semigroup a => a -> a -> a
<> Error
name forall a. Semigroup a => a -> a -> a
<> Error
": " forall a. Semigroup a => a -> a -> a
<> Error
err
            | (Error
name, Left Error
err) <- forall k a. Map k a -> [(k, a)]
Map.toList Map Error (Either Error Patch)
pmap
            ] forall a. [a] -> [a] -> [a]
++
            [ Error
"faust: patch code with no patch: " forall a. Semigroup a => a -> a -> a
<> Error
name
            | (Error
name, Lists.Second 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
            ]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ([Error]
errors,)
        [ (Error
name, FilePath -> Patch -> Patch
makePatch FilePath
imDir Patch
patch)
        | (Error
name, Right Patch
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 = 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
        [ 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 forall f a. Lens f a -> a -> f -> f
#= Error -> Doc
Doc.Doc (forall ptr cptr. PatchT ptr cptr -> Error
InstrumentC._doc Patch
patch) forall a b. (a -> b) -> a -> b
$
    Bool -> [Control] -> Patch -> Patch
code Bool
constantPitch [Control]
constantControls forall a b. (a -> b) -> a -> b
$
    Patch -> Patch
ImInst.make_patch forall a b. (a -> b) -> a -> b
$ Patch
Patch.patch
        { patch_controls :: Map Control Error
Patch.patch_controls = (forall a. Pretty a => a -> Error
pretty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Control ControlConfig
controls) forall a. Semigroup a => a -> a -> a
<> Map Control Error
standardControls
        , patch_elements :: Set Error
Patch.patch_elements = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=Error
"") forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$
            forall k a. Map k a -> [k]
Map.keys forall a b. (a -> b) -> a -> b
$ forall ptr cptr.
PatchT ptr cptr -> Map (Error, Control) (cptr, ControlConfig)
InstrumentC._controls Patch
patch
        }
    where
    constantControls :: [Control]
constantControls = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (ControlConfig -> Bool
InstrumentC._constant forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
        forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/=Control
Control.pitch) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map Control ControlConfig
controls
    constantPitch :: Bool
constantPitch = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ControlConfig -> Bool
InstrumentC._constant forall a b. (a -> b) -> a -> b
$
        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 = 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 #=) forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
        [ if Bool
constantPitch Bool -> Bool -> Bool
|| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Control]
constantControls)
            then Generator Note -> Code
ImInst.null_call forall a b. (a -> b) -> a -> b
$
                Bool -> Set Control -> Generator Note
DUtil.constant_controls Bool
constantPitch
                    (forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> b) -> [a] -> [b]
map Control -> Control
control [Control]
constantControls))
            else forall a. Monoid a => a
mempty
        , Map NoteNumber FilePath -> Code
thruCode Map NoteNumber FilePath
pitchToSample
        , case forall ptr cptr. PatchT ptr cptr -> Maybe Error
InstrumentC._elementFrom Patch
patch of
            Maybe Error
Nothing -> forall a. Monoid a => a
mempty
            Just Error
elementFrom -> InstrumentPostproc -> Code
ImInst.postproc forall a b. (a -> b) -> a -> b
$
                Error -> InstrumentPostproc
DUtil.element_from_id Error
elementFrom
        , forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall a. Monoid a => a
mempty (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 (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 = 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.
    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 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Play] -> Message
Thru.Plays forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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 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 -> forall a b. a -> Either a b
Left a
"no samples"
            Just (NoteNumber
sampleNn, FilePath
sample) -> forall a b. b -> Either a b
Right 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 forall a. Fractional a => a -> a -> a
/ NoteNumber -> Y
Pitch.nn_to_hz NoteNumber
nn