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