-- 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.Patch.Zheng where
import qualified Data.Char as Char
import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified System.Directory as Directory
import           System.FilePath ((</>))
import qualified Text.Read as Read

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

import qualified Cmd.Instrument.ImInst as ImInst
import qualified Derive.Attrs as Attrs
import qualified Derive.C.Prelude.Highlight as Highlight
import qualified Derive.Call.Make as Make
import qualified Derive.Call.Module as Module
import qualified Derive.Derive as Derive
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Instrument.DUtil as DUtil
import qualified Derive.PSignal as PSignal
import qualified Derive.Scale.Twelve as Twelve
import qualified Derive.ShowVal as ShowVal

import qualified Instrument.Common as Common
import qualified Midi.Midi as Midi
import qualified Perform.Im.Patch as Im.Patch
import qualified Perform.NN as NN
import qualified Perform.Pitch as Pitch
import qualified Perform.RealTime as RealTime

import qualified Synth.Sampler.Patch as Patch
import qualified Synth.Sampler.Patch.Lib.Util as Util
import qualified Synth.Sampler.Patch.ZhengSamples as ZhengSamples
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


patches :: [Patch.Patch]
patches :: [Patch]
patches = (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ (Error -> Patch
Patch.patch Error
"zheng")
    { _dir :: [Char]
Patch._dir = [Char]
dir
    , _convert :: Note -> ConvertM Sample
Patch._convert = Note -> ConvertM Sample
convert
    , _allFilenames :: Set [Char]
Patch._allFilenames = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ Map Int (Map Key (Map Int [[Char]]))
ZhengSamples.samples
    , _preprocess :: [Note] -> [Note]
Patch._preprocess = [Note] -> [Note]
inferDuration
    , _karyaPatch :: Patch
Patch._karyaPatch = Lens Patch Code
ImInst.code forall f a. Lens f a -> a -> f -> f
#= Code
code forall a b. (a -> b) -> a -> b
$ (NoteNumber, NoteNumber) -> Patch -> Patch
ImInst.nn_range (NoteNumber, NoteNumber)
range forall a b. (a -> b) -> a -> b
$
        Patch -> Patch
ImInst.make_patch forall a b. (a -> b) -> a -> b
$ Patch
Im.Patch.patch
            { patch_controls :: Map Control Error
Im.Patch.patch_controls = forall a. Monoid a => [a] -> a
mconcat
                [ Map Control Error
Control.supportPitch
                , Map Control Error
Control.supportDyn
                , Map Control Error
Control.supportVariation
                ] forall a. Semigroup a => a -> a -> a
<> forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                [ (Control
c_damp, Error
"Notes don't ring when this is 1.")
                , (Control
c_damp_time, Error
"Time in seconds to 0.")
                ]
            , patch_attribute_map :: AttributeMap
Im.Patch.patch_attribute_map = forall a b. a -> b -> a
const () forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AttributeMap Articulation
attributeMap
            }
    }
    where
    dir :: [Char]
dir = [Char]
"zheng"
    code :: Code
code = [Call Note] -> Code
ImInst.note_calls
        [ forall d. Symbol -> Calls d -> Call d
ImInst.both Symbol
"左" (Module -> Attributes -> Calls Note
Make.attributed_note Module
Module.instrument Attributes
Attrs.left)
        , forall d. Symbol -> Transformer d -> Call d
ImInst.transformer Symbol
"standard-strings" Transformer Note
standard_strings
        ]
        forall a. Semigroup a => a -> a -> a
<> Generator Note -> Code
ImInst.null_call Generator Note
Highlight.c_highlight_strings_note
        forall a. Semigroup a => a -> a -> a
<> [Char] -> (Note -> ConvertM Sample) -> Code
Util.thru [Char]
dir Note -> ConvertM Sample
convert
        forall a. Semigroup a => a -> a -> a
<> InstrumentPostproc -> Code
ImInst.postproc
            (forall old new.
(Typecheck old, ToVal new) =>
Error -> (old -> Either Msg new) -> InstrumentPostproc
DUtil.element_from Error
EnvKey.string Pitch -> Either Msg Error
show_string)
    -- copy paste from User.Elaforge.Instrument.Kontakt
    -- TODO put it in a shared module?
    -- This can't go in the automatic env because it uses DeriveT.Pitch, which
    -- is not serializable, hence not in REnv.
    standard_strings :: Transformer Note
standard_strings = forall d.
Taggable d =>
CallName -> Doc -> TransformerF d -> Transformer d
DUtil.transformer0 CallName
"standard-strings"
        (Doc
"Set " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc Error
EnvKey.open_strings
            forall a. Semigroup a => a -> a -> a
<> Doc
" to standard pitches: " forall a. Semigroup a => a -> a -> a
<> forall a. ShowVal a => a -> Doc
ShowVal.doc [NoteNumber]
open_strings)
        forall a b. (a -> b) -> a -> b
$ \PassedArgs Note
_ -> forall val a. ToVal val => Error -> val -> Deriver a -> Deriver a
Derive.with_val Error
EnvKey.open_strings
            (forall a b. (a -> b) -> [a] -> [b]
map NoteNumber -> Pitch
Twelve.nn_pitch [NoteNumber]
open_strings)
    open_strings :: [NoteNumber]
open_strings = forall a. Int -> [a] -> [a]
take (Int
4forall a. Num a => a -> a -> a
*Int
5 forall a. Num a => a -> a -> a
+ Int
1) forall a b. (a -> b) -> a -> b
$ -- 4 octaves + 1, so D to D
        forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((\[NoteNumber]
nns NoteNumber
oct -> forall a b. (a -> b) -> [a] -> [b]
map (NoteNumber
oct+) [NoteNumber]
nns) [NoteNumber]
notes) [NoteNumber]
octaves
        where
        notes :: [NoteNumber]
notes = [NoteNumber
NN.d2, NoteNumber
NN.e2, NoteNumber
NN.fs2, NoteNumber
NN.a2, NoteNumber
NN.b2]
        octaves :: [NoteNumber]
octaves = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral [Integer
0, Integer
12 ..]
    -- Let's say the top string can bend a minor third.
    range :: (NoteNumber, NoteNumber)
range = (forall a. [a] -> a
head [NoteNumber]
open_strings, forall a. [a] -> a
last [NoteNumber]
open_strings forall a. Num a => a -> a -> a
+ NoteNumber
3)

show_string :: PSignal.Pitch -> Either Log.Msg Text
show_string :: Pitch -> Either Msg Error
show_string = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (HasCallStack => Priority -> Maybe Stack -> Error -> Msg
Log.msg Priority
Log.Warn forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Error
pretty) Note -> Error
Pitch.note_text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transposed -> Either PitchError Note
PSignal.pitch_note forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. RawPitch a -> RawPitch b
PSignal.coerce

convert :: Note.Note -> Patch.ConvertM Sample.Sample
convert :: Note -> ConvertM Sample
convert Note
note = do
    Articulation
art <- forall (m :: * -> *) a.
MonadError Error m =>
AttributeMap a -> Attributes -> m a
Util.articulation AttributeMap Articulation
attributeMap (Note -> Attributes
Note.attributes Note
note)
    let dynVal :: Y
dynVal = Control -> Note -> Y
Note.initial0 Control
Control.dynamic Note
note
    let var :: Y
var = Control -> Note -> Y
Note.initial0 Control
Control.variation Note
note
    NoteNumber
noteNn <- forall (m :: * -> *). MonadError Error m => Note -> m NoteNumber
Util.initialPitch Note
note
    (Key
key, Y
sampleDyn, [Char]
filename) <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust Error
"no sample" forall a b. (a -> b) -> a -> b
$
        NoteNumber -> Articulation -> Y -> Y -> Maybe (Key, Y, [Char])
toFilename NoteNumber
noteNn Articulation
art Y
dynVal Y
var
    -- The bottom of the scale should be enough to smooth out the volume
    -- differences between each velocity group.  It's surely highly variable,
    -- but this seems to sound ok in practice.
    let vol :: Y
vol = forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale Y
0 Y
1 (Y
1 forall a. Num a => a -> a -> a
- (Y
sampleDyn forall a. Num a => a -> a -> a
- Y
dynVal))
    let dampTime :: RealTime
dampTime = forall b a. b -> (a -> b) -> Maybe a -> b
maybe RealTime
defaultDampTime Y -> RealTime
RealTime.seconds forall a b. (a -> b) -> a -> b
$
            RealTime -> Control -> Note -> Maybe Y
Note.controlAt (Note -> RealTime
Note.end Note
note) Control
c_damp_time Note
note
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ([Char] -> Sample
Sample.make [Char]
filename)
        { envelope :: Signal
Sample.envelope = forall {k} (kind :: k). [(RealTime, Y)] -> Signal kind
Signal.from_pairs
            [ (Note -> RealTime
Note.start Note
note, Y
vol), (Note -> RealTime
Note.end Note
note, Y
vol)
            , (Note -> RealTime
Note.end Note
note forall a. Num a => a -> a -> a
+ RealTime
dampTime, Y
0)
            ]
        , ratios :: Signal
Sample.ratios = NoteNumber -> Note -> Signal
Sample.pitchToRatioSignal (forall a. Num a => Key -> a
Midi.from_key Key
key) Note
note
        }

defaultDampTime :: RealTime
defaultDampTime :: RealTime
defaultDampTime = RealTime
0.75

toFilename :: Pitch.NoteNumber -> Articulation -> Signal.Y -> Signal.Y
    -> Maybe (Midi.Key, Signal.Y, FilePath)
toFilename :: NoteNumber -> Articulation -> Y -> Y -> Maybe (Key, Y, [Char])
toFilename NoteNumber
nn Articulation
art Y
dyn Y
var = do
    (Key
key, Map Int [[Char]]
velToFiles) <- forall k v. (Ord k, Num k) => k -> Map k v -> Maybe (k, v)
Maps.lookupClosest (forall a. Integral a => a -> Key
Midi.to_key (forall a b. (RealFrac a, Integral b) => a -> b
round NoteNumber
nn))
        (Articulation -> Map Key (Map Int [[Char]])
samples Articulation
art)
    -- TODO pick some from neighbors, since I lost variations due to combining
    -- them
    -- TODO also scale by difference from maxVel
    (Int
sampleVel, [[Char]]
filenames) <- forall k v. Ord k => k -> Map k v -> Maybe (k, v)
Map.lookupGE
        (forall a b. (RealFrac a, Integral b) => a -> b
round (forall a. Ord a => a -> a -> a -> a
Num.clamp Y
0 Y
127 (forall a. (Eq a, Num a) => a -> a -> a -> a
Num.scale Y
0 Y
127 Y
dyn)))
        Map Int [[Char]]
velToFiles
    forall (m :: * -> *) a. Monad m => a -> m a
return
        ( Key
key
        , forall a. (Eq a, Fractional a) => a -> a -> a -> a
Num.normalize Y
0 Y
127 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sampleVel)
        , forall a. [a] -> Y -> a
Util.pickVariation [[Char]]
filenames Y
var
        )

data Articulation = RightHand | LeftHand | Harmonic
    deriving (Articulation -> Articulation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Articulation -> Articulation -> Bool
$c/= :: Articulation -> Articulation -> Bool
== :: Articulation -> Articulation -> Bool
$c== :: Articulation -> Articulation -> Bool
Eq, Eq Articulation
Articulation -> Articulation -> Bool
Articulation -> Articulation -> Ordering
Articulation -> Articulation -> Articulation
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Articulation -> Articulation -> Articulation
$cmin :: Articulation -> Articulation -> Articulation
max :: Articulation -> Articulation -> Articulation
$cmax :: Articulation -> Articulation -> Articulation
>= :: Articulation -> Articulation -> Bool
$c>= :: Articulation -> Articulation -> Bool
> :: Articulation -> Articulation -> Bool
$c> :: Articulation -> Articulation -> Bool
<= :: Articulation -> Articulation -> Bool
$c<= :: Articulation -> Articulation -> Bool
< :: Articulation -> Articulation -> Bool
$c< :: Articulation -> Articulation -> Bool
compare :: Articulation -> Articulation -> Ordering
$ccompare :: Articulation -> Articulation -> Ordering
Ord, Int -> Articulation -> ShowS
[Articulation] -> ShowS
Articulation -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Articulation] -> ShowS
$cshowList :: [Articulation] -> ShowS
show :: Articulation -> [Char]
$cshow :: Articulation -> [Char]
showsPrec :: Int -> Articulation -> ShowS
$cshowsPrec :: Int -> Articulation -> ShowS
Show, Int -> Articulation
Articulation -> Int
Articulation -> [Articulation]
Articulation -> Articulation
Articulation -> Articulation -> [Articulation]
Articulation -> Articulation -> Articulation -> [Articulation]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Articulation -> Articulation -> Articulation -> [Articulation]
$cenumFromThenTo :: Articulation -> Articulation -> Articulation -> [Articulation]
enumFromTo :: Articulation -> Articulation -> [Articulation]
$cenumFromTo :: Articulation -> Articulation -> [Articulation]
enumFromThen :: Articulation -> Articulation -> [Articulation]
$cenumFromThen :: Articulation -> Articulation -> [Articulation]
enumFrom :: Articulation -> [Articulation]
$cenumFrom :: Articulation -> [Articulation]
fromEnum :: Articulation -> Int
$cfromEnum :: Articulation -> Int
toEnum :: Int -> Articulation
$ctoEnum :: Int -> Articulation
pred :: Articulation -> Articulation
$cpred :: Articulation -> Articulation
succ :: Articulation -> Articulation
$csucc :: Articulation -> Articulation
Enum)

attributeMap :: Common.AttributeMap Articulation
attributeMap :: AttributeMap Articulation
attributeMap = forall a. [(Attributes, a)] -> AttributeMap a
Common.attribute_map
    [ (Attributes
Attrs.harm, Articulation
Harmonic)
    , (Attributes
Attrs.left, Articulation
LeftHand)
    , (forall a. Monoid a => a
mempty, Articulation
RightHand)
    ]

samples :: Articulation -> Map Midi.Key (Map MaxVelocity [FilePath])
samples :: Articulation -> Map Key (Map Int [[Char]])
samples Articulation
art = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error ([Char]
"unknown articulation: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Articulation
art)) forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall a. Enum a => a -> Int
fromEnum Articulation
art) Map Int (Map Key (Map Int [[Char]]))
ZhengSamples.samples

-- * preprocess

c_damp :: Control.Control
c_damp :: Control
c_damp = Control
"damp"

c_damp_time :: Control.Control
c_damp_time :: Control
c_damp_time = Control
"damp-time"

-- | Interpret the 'c_damp' control.  Each note extends until there's a note
-- with a c_damp with 1.
inferDuration :: [Note.Note] -> [Note.Note]
inferDuration :: [Note] -> [Note]
inferDuration = forall a b. (a -> b) -> [a] -> [b]
map (Note, [Note]) -> Note
infer forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [(a, [a])]
Util.nexts
    where
    -- It would be more efficient to find the next damp, then remember it until
    -- I pass it.  But the difference probably doesn't matter.
    infer :: (Note, [Note]) -> Note
infer (Note
note, [Note]
nexts) = Note
note
        { duration :: RealTime
Note.duration = forall b a. b -> (a -> b) -> Maybe a -> b
maybe RealTime
Sample.forever (\RealTime
end -> RealTime
end forall a. Num a => a -> a -> a
- Note -> RealTime
Note.start Note
note)
            (Note -> [Note] -> Maybe RealTime
inferEnd Note
note [Note]
nexts)
        }

inferEnd :: Note.Note -> [Note.Note] -> Maybe RealTime
inferEnd :: Note -> [Note] -> Maybe RealTime
inferEnd Note
note [Note]
nexts = case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Note -> Maybe RealTime
dampedAt (Note
note forall a. a -> [a] -> [a]
: [Note]
nexts) of
    [] -> forall a. Maybe a
Nothing
    RealTime
end : [RealTime]
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max RealTime
end (Note -> RealTime
Note.end Note
note)
    where
    dampedAt :: Note -> Maybe RealTime
dampedAt = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (kind :: k).
(RealTime -> Y -> Bool) -> Signal kind -> Maybe (RealTime, Y)
Signal.find (\RealTime
_ Y
y -> Y
y forall a. Ord a => a -> a -> Bool
>= Y
1)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
c_damp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Map Control Signal
Note.controls

-- * make samples

data Sample = Sample {
    Sample -> Key
_key :: !Midi.Key
    , Sample -> Articulation
_articulation :: !Articulation
    , Sample -> Int
_variation :: !Util.Variation
    , Sample -> Int
_maxVelocity :: !MaxVelocity
    } deriving (Int -> Sample -> ShowS
[Sample] -> ShowS
Sample -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Sample] -> ShowS
$cshowList :: [Sample] -> ShowS
show :: Sample -> [Char]
$cshow :: Sample -> [Char]
showsPrec :: Int -> Sample -> ShowS
$cshowsPrec :: Int -> Sample -> ShowS
Show)

type MaxVelocity = Int

-- | Call this to generate ZhengSamples, which is imported as 'samples'.
_writeSamplesModule :: IO ()
_writeSamplesModule :: IO ()
_writeSamplesModule = do
    [[Char]]
fns <- [Char] -> IO [[Char]]
Directory.listDirectory ([Char]
Config.unsafeSamplerRoot [Char] -> ShowS
</> [Char]
"zheng")
    [Char] -> [Char] -> IO ()
writeFile [Char]
output forall a b. (a -> b) -> a -> b
$ [Char]
samplesModuleHeader forall a. Semigroup a => a -> a -> a
<> [[Char]] -> [Char]
makeSamples [[Char]]
fns
    where
    output :: [Char]
output = [Char]
"Synth/Sampler/Patch/ZhengSamples.hs"

parseFilename :: FilePath -> Maybe Sample
parseFilename :: [Char] -> Maybe Sample
parseFilename (Char
'S':Char
'C':Char
'G':Char
'Z':Char
key1:Char
key2:Char
_:Char
art:Char
'-':[Char]
rest) = do
    Key
key <- Int -> Key
Midi.Key forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Read a => [Char] -> Maybe a
Read.readMaybe (Char
key1forall a. a -> [a] -> [a]
:Char
key2forall a. a -> [a] -> [a]
:[Char]
"")
    Articulation
art <- case Char
art of
        Char
'R' -> forall a. a -> Maybe a
Just Articulation
RightHand
        Char
'L' -> forall a. a -> Maybe a
Just Articulation
LeftHand
        Char
'H' -> forall a. a -> Maybe a
Just Articulation
Harmonic
        Char
_ -> forall a. Maybe a
Nothing
    (Int
var, Int
maxVel) <- case Articulation
art of
        Articulation
Harmonic -> (Int
0,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Read a => [Char] -> Maybe a
Read.readMaybe (forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
Char.isDigit [Char]
rest)
        Articulation
_ -> case [Char]
rest of
            Char
n : [Char]
rest -> (forall a. Enum a => a -> Int
fromEnum Char
n forall a. Num a => a -> a -> a
- forall a. Enum a => a -> Int
fromEnum Char
'A',) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                forall a. Read a => [Char] -> Maybe a
Read.readMaybe (forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
Char.isDigit [Char]
rest)
            [Char]
_ -> forall a. Maybe a
Nothing
    -- One sample is mislabeled.
    Key
key <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Key
key forall a. Eq a => a -> a -> Bool
== Key
80 then Key
81 else Key
key
    -- Harmonics are given an octave below their sounding pitch.
    Key
key <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Articulation
art forall a. Eq a => a -> a -> Bool
== Articulation
Harmonic then Key
key forall a. Num a => a -> a -> a
+ Key
12 else Key
key
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Key -> Articulation -> Int -> Int -> Sample
Sample Key
key Articulation
art Int
var Int
maxVel
parseFilename [Char]
_ = forall a. Maybe a
Nothing

makeSampleMap :: [FilePath]
    -> Map Articulation (Map Midi.Key (Map MaxVelocity [FilePath]))
makeSampleMap :: [[Char]] -> Map Articulation (Map Key (Map Int [[Char]]))
makeSampleMap =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd)))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {k} {b} {b}. Ord k => (b -> k) -> [(b, b)] -> Map k [(b, b)]
groupOn Sample -> Int
_maxVelocity))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {k} {b} {b}. Ord k => (b -> k) -> [(b, b)] -> Map k [(b, b)]
groupOn Sample -> Key
_key)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} {b} {b}. Ord k => (b -> k) -> [(b, b)] -> Map k [(b, b)]
groupOn Sample -> Articulation
_articulation
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a k. (a -> Maybe k) -> [a] -> [(k, a)]
Lists.keyOnJust [Char] -> Maybe Sample
parseFilename
    where
    groupOn :: (b -> k) -> [(b, b)] -> Map k [(b, b)]
groupOn b -> k
key = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])]
Lists.keyedGroupSort (b -> k
key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)

makeSamples :: [FilePath] -> String
makeSamples :: [[Char]] -> [Char]
makeSamples = forall a. Show a => a -> [Char]
PPrint.pshow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys forall a. Enum a => a -> Int
fromEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> Map Articulation (Map Key (Map Int [[Char]]))
makeSampleMap

samplesModuleHeader :: String
samplesModuleHeader :: [Char]
samplesModuleHeader =
    [Char]
"-- Copyright 2019 Evan Laforge\n\
    \-- This program is distributed under the terms of the GNU General Public\n\
    \-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt\n\
    \\n\
    \-- | This module was generated by Zheng._writeSamplesModule.\n\
    \module Synth.Sampler.Patch.ZhengSamples (samples) where\n\
    \import Data.Map (Map, fromList)\n\
    \import Midi.Midi (Key(Key))\n\
    \\n\
    \samples :: Map Int (Map Key (Map Int [FilePath]))\n\
    \samples = "