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

module Synth.Sampler.Patch where
import qualified Control.Monad.Except as Except
import qualified Control.Monad.Identity as Identity
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Util.Log as Log
import qualified Util.Maps as Maps
import qualified Util.Lists as Lists

import qualified Cmd.Instrument.ImInst as ImInst
import qualified Perform.Im.Patch as Im.Patch
import qualified Perform.Pitch as Pitch
import qualified Synth.Sampler.Sample as Sample
import qualified Synth.Shared.Control as Control
import qualified Synth.Shared.Note as Note
import qualified Synth.Shared.Signal as Signal

import           Global


db :: FilePath -> [Patch] -> Db
db :: FilePath -> [Patch] -> Db
db FilePath
rootDir [Patch]
patches = Db
    { _rootDir :: FilePath
_rootDir = FilePath
rootDir
    , _patches :: Map Text Patch
_patches = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a k. (a -> k) -> [a] -> [(k, a)]
Lists.keyOn Patch -> Text
_name [Patch]
patches
    }

data Db = Db {
    -- | Base directory for patches.  Samples are in '_rootDir' / '_dir'.
    Db -> FilePath
_rootDir :: !FilePath
    , Db -> Map Text Patch
_patches :: !(Map Note.PatchName Patch)
    }

lookupPatch :: Note.PatchName -> [Patch] -> Maybe Patch
lookupPatch :: Text -> [Patch] -> Maybe Patch
lookupPatch Text
name = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((forall a. Eq a => a -> a -> Bool
==Text
name) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Patch -> Text
_name)

data Patch = Patch {
    Patch -> Text
_name :: Note.PatchName
    -- | Root dir for samples, relative to '_rootDir'.  This is not the same
    -- as '_name' because multiple patches may share a sample directory.
    , Patch -> FilePath
_dir :: FilePath
    -- | Find a sample.
    , Patch -> Note -> ConvertM Sample
_convert :: Note.Note -> ConvertM Sample.Sample
    , Patch -> [Note] -> [Note]
_preprocess :: [Note.Note] -> [Note.Note]
    , Patch -> Maybe EffectConfig
_effect :: !(Maybe EffectConfig)
    -- | Karya configuration.
    --
    -- Putting code here means that the sampler has to link in a large portion
    -- of karya.  To avoid this I'd have to maintain a separate DB in the
    -- sequencer that matches up by name.  For the moment, linking in the extra
    -- code doesn't seem like a problem.
    , Patch -> Patch
_karyaPatch :: ImInst.Patch
    -- | All samples this patch will read, used to test that they all exist.
    -- Relative to '_dir'.  '_convert' is an arbitrary function, so there's
    -- no way to introspect this out, but most should be created with utilities
    -- that can also fill in the filenames.
    , Patch -> Set FilePath
_allFilenames :: Set FilePath
    }

patch :: Note.PatchName -> Patch
patch :: Text -> Patch
patch Text
name = Patch
    { _name :: Text
_name = Text
name
    , _dir :: FilePath
_dir = Text -> FilePath
untxt Text
name
    , _convert :: Note -> ConvertM Sample
_convert = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Text
"not implemented"
    , _preprocess :: [Note] -> [Note]
_preprocess = forall a. a -> a
id
    , _effect :: Maybe EffectConfig
_effect = forall a. Maybe a
Nothing
    , _karyaPatch :: Patch
_karyaPatch = Patch -> Patch
ImInst.make_patch Patch
Im.Patch.patch
    , _allFilenames :: Set FilePath
_allFilenames = forall a. Monoid a => a
mempty
    }

patchKarya :: Note.PatchName -> (ImInst.Patch -> ImInst.Patch) -> Patch
patchKarya :: Text -> (Patch -> Patch) -> Patch
patchKarya Text
name Patch -> Patch
setKarya = Patch
    { _name :: Text
_name = Text
name
    , _dir :: FilePath
_dir = Text -> FilePath
untxt Text
name
    , _convert :: Note -> ConvertM Sample
_convert = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => e -> m a
Except.throwError Text
"not implemented"
    , _preprocess :: [Note] -> [Note]
_preprocess = forall a. a -> a
id
    , _effect :: Maybe EffectConfig
_effect = forall a. Maybe a
Nothing
    , _karyaPatch :: Patch
_karyaPatch = Patch -> Patch
setKarya forall a b. (a -> b) -> a -> b
$ Patch -> Patch
ImInst.make_patch Patch
Im.Patch.patch
    , _allFilenames :: Set FilePath
_allFilenames = forall a. Monoid a => a
mempty
    }

-- | Make a simple patch of a single sample.
simple :: Note.PatchName -> Sample.SamplePath -> Pitch.NoteNumber -> Patch
simple :: Text -> FilePath -> NoteNumber -> Patch
simple Text
name FilePath
filename NoteNumber
sampleNn = (Text -> Patch
patch Text
name)
    { _convert :: Note -> ConvertM Sample
_convert = \Note
note -> do
        NoteNumber
pitch <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust Text
"no pitch" forall a b. (a -> b) -> a -> b
$ Note -> Maybe NoteNumber
Note.initialPitch Note
note
        Y
dyn <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust Text
"no dyn" forall a b. (a -> b) -> a -> b
$ Control -> Note -> Maybe Y
Note.initial Control
Control.dynamic Note
note
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (FilePath -> Sample
Sample.make FilePath
filename)
            { envelope :: Signal
Sample.envelope = forall {k} (kind :: k). Y -> Signal kind
Signal.constant Y
dyn
            , ratios :: Signal
Sample.ratios = forall {k} (kind :: k). Y -> Signal kind
Signal.constant forall a b. (a -> b) -> a -> b
$
                NoteNumber -> NoteNumber -> Y
Sample.pitchToRatio NoteNumber
sampleNn NoteNumber
pitch
            }
    , _allFilenames :: Set FilePath
_allFilenames = forall a. a -> Set a
Set.singleton FilePath
filename
    , _karyaPatch :: Patch
_karyaPatch = Patch -> Patch
ImInst.make_patch forall a b. (a -> b) -> a -> b
$ Patch
Im.Patch.patch
        { patch_controls :: Map Control Text
Im.Patch.patch_controls = Map Control Text
Control.supportPitch forall a. Semigroup a => a -> a -> a
<> Map Control Text
Control.supportDyn
        }
    }

addCode :: ImInst.Code -> Patch -> Patch
addCode :: Code -> Patch -> Patch
addCode Code
code Patch
patch = Patch
patch
    { _karyaPatch :: Patch
_karyaPatch = Lens Patch Code
ImInst.code forall f a. Lens f a -> (a -> a) -> f -> f
%= (Code
code<>) forall a b. (a -> b) -> a -> b
$ Patch -> Patch
_karyaPatch Patch
patch }

type ConvertM a = Log.LogT (Except.ExceptT Error Identity.Identity) a
type Error = Text

convert :: Patch -> Note.Note -> Either Error (Sample.Sample, [Log.Msg])
convert :: Patch -> Note -> Either Text (Sample, [Msg])
convert Patch
patch Note
note =
    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Note -> Sample -> Sample
applyStandardControls Note
note) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ConvertM a -> Either Text (a, [Msg])
runConvert (Patch -> Note -> ConvertM Sample
_convert Patch
patch Note
note)

runConvert :: ConvertM a -> Either Error (a, [Log.Msg])
runConvert :: forall a. ConvertM a -> Either Text (a, [Msg])
runConvert = forall a. Identity a -> a
Identity.runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => LogT m a -> m (a, [Msg])
Log.run

-- | Apply standard controls that all patches support.
applyStandardControls :: Note.Note -> Sample.Sample -> Sample.Sample
applyStandardControls :: Note -> Sample -> Sample
applyStandardControls Note
note =
    forall {a}. Control -> (Signal -> a -> a) -> a -> a
apply Control
Control.volume (\Signal
sig Sample
sample -> Sample
sample
        { envelope :: Signal
Sample.envelope = Signal -> Signal -> Signal
Signal.sig_multiply Signal
sig (Sample -> Signal
Sample.envelope Sample
sample) })
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Control -> (Signal -> a -> a) -> a -> a
apply Control
Control.pan (\Signal
sig Sample
sample -> Sample
sample
        { pan :: Signal
Sample.pan = Signal -> Signal -> Signal
Signal.sig_add Signal
sig (Sample -> Signal
Sample.pan Sample
sample) })
    where
    apply :: Control -> (Signal -> a -> a) -> a -> a
apply Control
c Signal -> a -> a
set = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id Signal -> a -> a
set (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
c (Note -> Map Control Signal
Note.controls Note
note))

standardControls :: Map Control.Control Text
standardControls :: Map Control Text
standardControls = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Control
Control.volume, Text
"Low level volume, in dB.")
    , (Control
Control.pan, Text
"Pan, where -1 is left, and 1 is right.")
    ]


-- * EffectConfig

data EffectConfig = EffectConfig {
    EffectConfig -> Text
_effectName :: Text
    -- | Map event controls to effect controls.  So if the effect exports
    -- "effect-feedback" and we want to refer to it as "depth", then
    -- ("depth", "effect-feedback").
    , EffectConfig -> Map Control Control
_toEffectControl :: !(Map Control.Control Control.Control)
    } deriving (Int -> EffectConfig -> ShowS
[EffectConfig] -> ShowS
EffectConfig -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [EffectConfig] -> ShowS
$cshowList :: [EffectConfig] -> ShowS
show :: EffectConfig -> FilePath
$cshow :: EffectConfig -> FilePath
showsPrec :: Int -> EffectConfig -> ShowS
$cshowsPrec :: Int -> EffectConfig -> ShowS
Show)

effect :: Text -> EffectConfig
effect :: Text -> EffectConfig
effect Text
name = EffectConfig
    { _effectName :: Text
_effectName = Text
name
    , _toEffectControl :: Map Control Control
_toEffectControl = forall a. Monoid a => a
mempty
    }

-- | Check that rename sources exist.  Check that renamed controls don't
-- overlap patch controls.
checkControls :: Patch -> Set Control.Control -> EffectConfig -> [Text]
checkControls :: Patch -> Set Control -> EffectConfig -> [Text]
checkControls Patch
patch Set Control
effectControls EffectConfig
effectConfig = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ Text
"rename sources not in effect: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Set Control
unknownRenameFrom
      | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Control
unknownRenameFrom)
      ]
    , [ Text
"effect controls overlap with patch: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Set Control
patchOverlaps
      | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Control
patchOverlaps)
      ]
    ]
    where
    toScoreControl :: Map Control Control
toScoreControl = forall a k. Ord a => Map k a -> Map a k
Maps.invert forall a b. (a -> b) -> a -> b
$ EffectConfig -> Map Control Control
_toEffectControl EffectConfig
effectConfig
    unknownRenameFrom :: Set Control
unknownRenameFrom =
        forall k a. Map k a -> Set k
Map.keysSet Map Control Control
toScoreControl forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Control
effectControls
    renamed :: Set Control
renamed =
        forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\Control
c -> forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Control
c Control
c Map Control Control
toScoreControl) Set Control
effectControls
    patchOverlaps :: Set Control
patchOverlaps = forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set Control
renamed Set Control
patchControls
    patchControls :: Set Control
patchControls = forall k a. Map k a -> Set k
Map.keysSet forall a b. (a -> b) -> a -> b
$ Patch -> Map Control Text
Im.Patch.patch_controls forall a b. (a -> b) -> a -> b
$
        Patch -> Patch
ImInst.patch_patch forall a b. (a -> b) -> a -> b
$ Patch -> Patch
_karyaPatch Patch
patch