-- Copyright 2019 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.Calibrate where import qualified Control.Monad.Trans.Resource as Resource import qualified Data.List as List import qualified Data.Map as Map import qualified System.Directory as Directory import qualified System.FilePath as FilePath import System.FilePath ((</>)) import qualified Util.Audio.Audio as Audio import qualified Util.Audio.File as Audio.File import qualified Util.Audio.Resample as Resample import qualified Util.Lists as Lists import qualified Derive.Attrs as Attrs import qualified Perform.RealTime as RealTime import qualified Synth.Lib.AUtil as AUtil import qualified Synth.Sampler.RenderSample as RenderSample import qualified Synth.Sampler.Sample as Sample import qualified Synth.Shared.Config as Config import qualified Synth.Shared.Control as Control import qualified Synth.Shared.Note as Note import qualified Synth.Shared.Signal as Signal import Global import Synth.Types type Axis = Text select :: Eq b => [(Axis, b)] -> [(a, Map Axis b)] -> [(a, Map Axis b)] select :: forall b a. Eq b => [(Axis, b)] -> [(a, Map Axis b)] -> [(a, Map Axis b)] select [(Axis, b)] tags = forall a. (a -> Bool) -> [a] -> [a] filter (Map Axis b -> Bool hasTags forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> b snd) where hasTags :: Map Axis b -> Bool hasTags Map Axis b m = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all (\(Axis k, b v) -> forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup Axis k Map Axis b m forall a. Eq a => a -> a -> Bool == forall a. a -> Maybe a Just b v) [(Axis, b)] tags orderBy :: Ord b => [Axis] -> [(a, Map Axis b)] -> [a] orderBy :: forall b a. Ord b => [Axis] -> [(a, Map Axis b)] -> [a] orderBy [Axis] axes [(a, Map Axis b)] samples = forall a b. (a -> b) -> [a] -> [b] map forall a b. (a, b) -> b snd forall a b. (a -> b) -> a -> b $ forall b a. Ord b => (a -> b) -> [a] -> [a] List.sortOn forall a b. (a, b) -> a fst [ (forall a b. (a -> b) -> [a] -> [b] map (forall k a. Ord k => k -> Map k a -> Maybe a `Map.lookup` Map Axis b tags) [Axis] axes, a val) | (a val, Map Axis b tags) <- [(a, Map Axis b)] samples ] pitch, art, dyn, tuning, var :: Axis pitch :: Axis pitch = Axis "pitch" art :: Axis art = Axis "art" dyn :: Axis dyn = Axis "dyn" tuning :: Axis tuning = Axis "tuning" var :: Axis var = Axis "var" -- * render -- create notes with an even dyn spread data By = Attr | Pitch | Dyn deriving (Int -> By -> ShowS [By] -> ShowS By -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [By] -> ShowS $cshowList :: [By] -> ShowS show :: By -> String $cshow :: By -> String showsPrec :: Int -> By -> ShowS $cshowsPrec :: Int -> By -> ShowS Show, ReadPrec [By] ReadPrec By Int -> ReadS By ReadS [By] forall a. (Int -> ReadS a) -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a readListPrec :: ReadPrec [By] $creadListPrec :: ReadPrec [By] readPrec :: ReadPrec By $creadPrec :: ReadPrec By readList :: ReadS [By] $creadList :: ReadS [By] readsPrec :: Int -> ReadS By $creadsPrec :: Int -> ReadS By Read) sequence :: By -> Note.PatchName -> RealTime -> [Attrs.Attributes] -> [Note.Element] -> Signal.Y -> Signal.Y -> [Note.Note] sequence :: By -> Axis -> RealTime -> [Attributes] -> [Axis] -> Seconds -> Seconds -> [Note] sequence By by Axis patch RealTime dur [Attributes] attrs [Axis] pitches Seconds variations Seconds dynamics = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith RealTime -> Note -> Note setStart (forall a. Num a => a -> a -> [a] Lists.range_ RealTime 0 RealTime dur) forall a b. (a -> b) -> a -> b $ case By by of By Attr -> [ Axis -> Seconds -> Seconds -> Attributes -> Note make Axis pitch Seconds dyn Seconds var Attributes attr | Axis pitch <- [Axis] pitches , Seconds var <- [Seconds] vars , Seconds dyn <- [Seconds] dyns , Attributes attr <- [Attributes] attrs ] By Dyn -> [ Axis -> Seconds -> Seconds -> Attributes -> Note make Axis pitch Seconds dyn Seconds var Attributes attr | Attributes attr <- [Attributes] attrs , Axis pitch <- [Axis] pitches , Seconds var <- [Seconds] vars , Seconds dyn <- [Seconds] dyns ] By Pitch -> [ Axis -> Seconds -> Seconds -> Attributes -> Note make Axis pitch Seconds dyn Seconds var Attributes attr | Attributes attr <- [Attributes] attrs , Seconds var <- [Seconds] vars , Seconds dyn <- [Seconds] dyns , Axis pitch <- [Axis] pitches ] where vars :: [Seconds] vars = forall a. (Num a, Ord a) => a -> a -> a -> [a] Lists.range Seconds 0 Seconds 1 (Seconds 1 forall a. Fractional a => a -> a -> a / (Seconds variationsforall a. Num a => a -> a -> a -Seconds 1)) dyns :: [Seconds] dyns = forall a. (Num a, Ord a) => a -> a -> a -> [a] Lists.range Seconds 0 Seconds 1 (Seconds 1 forall a. Fractional a => a -> a -> a / (Seconds dynamicsforall a. Num a => a -> a -> a -Seconds 1)) setStart :: RealTime -> Note -> Note setStart RealTime start Note note = Note note { start :: RealTime Note.start = RealTime start } make :: Axis -> Seconds -> Seconds -> Attributes -> Note make Axis element Seconds dyn Seconds var Attributes attr = (Axis -> Instrument -> RealTime -> RealTime -> Note Note.note Axis patch Instrument "inst" RealTime 0 RealTime dur) { element :: Axis Note.element = Axis element , attributes :: Attributes Note.attributes = Attributes attr , duration :: RealTime Note.duration = RealTime dur , controls :: Map Control Signal Note.controls = forall k a. Ord k => [(k, a)] -> Map k a Map.fromList [ (Control Control.dynamic, forall {k} (kind :: k). Seconds -> Signal kind Signal.constant Seconds dyn) , (Control Control.variation, forall {k} (kind :: k). Seconds -> Signal kind Signal.constant Seconds var) ] } renderSequence :: FilePath -> RealTime -> [Sample.SamplePath] -> IO () renderSequence :: String -> RealTime -> [String] -> IO () renderSequence String outDir RealTime dur [String] fnames = do String -> Maybe Seconds -> [(RealTime, Sample)] -> IO () renderDirect (String outDir String -> ShowS </> String "out.wav") forall a. Maybe a Nothing [(RealTime, Sample)] samples where samples :: [(RealTime, Sample)] samples = forall a b. [a] -> [b] -> [(a, b)] zip (forall a. Num a => a -> a -> [a] Lists.range_ RealTime 0 RealTime dur) (forall a b. (a -> b) -> [a] -> [b] map String -> Sample makeSample [String] fnames) makeSample :: String -> Sample makeSample String fname = (String -> Sample Sample.make String fname) { envelope :: Signal Sample.envelope = forall {k} (kind :: k). [(RealTime, Seconds)] -> Signal kind Signal.from_pairs [(RealTime 0, Seconds 1), (RealTime dur forall a. Num a => a -> a -> a - RealTime decay, Seconds 1), (RealTime dur, Seconds 0)] } decay :: RealTime decay = RealTime 0.15 renderStarts :: FilePath -> [Sample.Sample] -> IO () renderStarts :: String -> [Sample] -> IO () renderStarts String outDir [Sample] samples = do String -> IO () putStrLn forall a b. (a -> b) -> a -> b $ String "==> " forall a. Semigroup a => a -> a -> a <> String filename [Bool] exist <- forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM (String -> IO Bool Directory.doesFileExist forall b c a. (b -> c) -> (a -> b) -> a -> c . (String patchDir</>) forall b c a. (b -> c) -> (a -> b) -> a -> c . Sample -> String Sample.filename) [Sample] samples if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all forall a. a -> a id [Bool] exist then String -> Maybe Seconds -> [(RealTime, Sample)] -> IO () renderDirect String filename (forall a. a -> Maybe a Just Seconds 1) forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map ((RealTime 0,) forall b c a. (b -> c) -> (a -> b) -> a -> c . ShowS -> Sample -> Sample Sample.modifyFilename (String patchDir</>)) [Sample] samples else String -> IO () putStrLn String "*** missing" where filename :: String filename = String outDir String -> ShowS </> forall {b}. Eq b => b -> b -> [b] -> [b] replace Char '/' Char '-' (ShowS FilePath.dropExtension (Sample -> String Sample.filename (forall a. [a] -> a head [Sample] samples))) forall a. [a] -> [a] -> [a] ++ String ".wav" patchDir :: String patchDir = String "../data/sampler/wayang" replace :: b -> b -> [b] -> [b] replace b a b b = forall a b. (a -> b) -> [a] -> [b] map (\b c -> if b c forall a. Eq a => a -> a -> Bool == b a then b b else b c) renderDirect :: FilePath -> Maybe Audio.Seconds -> [(RealTime, Sample.Sample)] -> IO () renderDirect :: String -> Maybe Seconds -> [(RealTime, Sample)] -> IO () renderDirect String filename Maybe Seconds dur [(RealTime, Sample)] samples = do [Audio (ResourceT IO) SamplingRate Channels] audios <- forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM (RealTime, Sample) -> IO (Audio (ResourceT IO) SamplingRate Channels) render [(RealTime, Sample)] samples forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a Resource.runResourceT forall a b. (a -> b) -> a -> b $ forall (rate :: Nat) (chan :: Nat). (KnownNat rate, KnownNat chan) => Format -> String -> AudioIO rate chan -> ResourceT IO () Audio.File.write Format AUtil.outputFormat String filename forall a b. (a -> b) -> a -> b $ forall b a. b -> (a -> b) -> Maybe a -> b maybe forall a. a -> a id forall (m :: * -> *) (rate :: Nat) (chan :: Nat). (Monad m, KnownNat rate, KnownNat chan) => Seconds -> Audio m rate chan -> Audio m rate chan Audio.takeS Maybe Seconds dur forall a b. (a -> b) -> a -> b $ forall (m :: * -> *) (rate :: Nat) (chan :: Nat). Monad m => [Audio m rate chan] -> Audio m rate chan Audio.mix [Audio (ResourceT IO) SamplingRate Channels] audios where render :: (RealTime, Sample) -> IO (Audio (ResourceT IO) SamplingRate Channels) render (RealTime offset, Sample sample) = (forall (m :: * -> *) (rate :: Nat) (chan :: Nat). (Monad m, KnownNat rate, KnownNat chan) => Seconds -> Audio m rate chan -> Audio m rate chan Audio.takeS (RealTime -> Seconds RealTime.to_seconds RealTime offset) forall (m :: * -> *) (chan :: Nat) (rate :: Nat). (Monad m, KnownNat chan) => Audio m rate chan Audio.silence <>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Config -> RealTime -> Sample -> IO (Audio (ResourceT IO) SamplingRate Channels) RenderSample.render Config config RealTime 0 Sample sample config :: Config config = Resample.Config { _quality :: Quality _quality = Quality Resample.SincFastest , _state :: Maybe SavedState _state = forall a. Maybe a Nothing , _notifyState :: Maybe (Frames, SavedState) -> IO () _notifyState = forall a b. a -> b -> a const forall a b. (a -> b) -> a -> b $ forall (m :: * -> *) a. Monad m => a -> m a return () , _blockSize :: Frames _blockSize = Frames Config.chunkSize , _now :: Frames _now = Frames 0 , _name :: String _name = String filename }