module Synth.Sampler.Patch.Reyong (patches) where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Util.Lists as Lists
import qualified Util.Maps as Maps
import qualified Cmd.Instrument.Bali as Bali
import qualified Cmd.Instrument.ImInst as ImInst
import qualified Derive.Attrs as Attrs
import qualified Derive.C.Prelude.Note as Prelude.Note
import qualified Derive.Call as Call
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Instrument.DUtil as DUtil
import qualified Derive.Scale as Scale
import qualified Derive.Scale.BaliScales as BaliScales
import qualified Derive.Scale.Legong as Legong
import qualified Derive.ShowVal as ShowVal
import qualified Instrument.Common as Common
import qualified Midi.Key as Key
import qualified Midi.Midi as Midi
import qualified Perform.Im.Patch as Im.Patch
import qualified Perform.Pitch as Pitch
import qualified Synth.Sampler.Patch as Patch
import qualified Synth.Sampler.Patch.Lib.Bali as Lib.Bali
import Synth.Sampler.Patch.Lib.Bali (Pitch(..), PitchClass(..))
import qualified Synth.Sampler.Patch.Lib.Code as Code
import qualified Synth.Sampler.Patch.Lib.Util as Util
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
import Synth.Types
patches :: [Patch.Patch]
patches :: [Patch]
patches =
[ Text -> Maybe Tuning -> Range -> Patch
makePatch Text
"reyong-trompong" forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ Pitch -> Pitch -> Range
Scale.Range
(Range -> Pitch
Scale.range_bottom Range
Legong.trompong_range)
(Range -> Pitch
Scale.range_top Range
Legong.reyong_range)
, Text -> Maybe Tuning -> Range -> Patch
makePatch Text
"reyong" (forall a. a -> Maybe a
Just Tuning
BaliScales.Isep) Range
Legong.reyong_range
, Text -> Maybe Tuning -> Range -> Patch
makePatch Text
"trompong" (forall a. a -> Maybe a
Just Tuning
BaliScales.Umbang) Range
Legong.trompong_range
]
makePatch :: Note.PatchName -> Maybe BaliScales.Tuning -> Scale.Range
-> Patch.Patch
makePatch :: Text -> Maybe Tuning -> Range -> Patch
makePatch Text
name Maybe Tuning
tuning Range
range = (Text -> Patch
Patch.patch Text
name)
{ _dir :: [Char]
Patch._dir = [Char]
dir
, _convert :: Note -> ConvertM Sample
Patch._convert = Note -> ConvertM Sample
convert
, _allFilenames :: Set [Char]
Patch._allFilenames = Set [Char]
allFilenames
, _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
$ Range -> Patch -> Patch
ImInst.range Range
range forall a b. (a -> b) -> a -> b
$
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a. ToVal a => Text -> a -> Patch -> Patch
ImInst.environ Text
EnvKey.tuning forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ShowVal a => a -> Text
ShowVal.show_val) Maybe Tuning
tuning 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 Text
Im.Patch.patch_controls = forall a. Monoid a => [a] -> a
mconcat
[ Map Control Text
Control.supportPitch
, Map Control Text
Control.supportDyn
, Map Control Text
Control.supportVariation
]
, 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
code :: Code
code = Code
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 InstrumentPostproc
DUtil.with_symbolic_pitch
note :: Code
note = Doc
-> (NoteArgs -> NoteDeriver -> NoteDeriver)
-> (NoteArgs -> NoteDeriver)
-> Code
Bali.zero_dur_mute_with Doc
""
(forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall {a}. Deriver a -> Deriver a
transform forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Y -> Deriver a -> Deriver a
Call.multiply_dynamic Y
0.8)
(\NoteArgs
args -> forall {a}. Deriver a -> Deriver a
transform forall a b. (a -> b) -> a -> b
$
Config -> NoteArgs -> NoteDeriver
Prelude.Note.default_note Config
Prelude.Note.use_attributes NoteArgs
args)
where transform :: Deriver a -> Deriver a
transform = forall {a}. Deriver a -> Deriver a
Code.withVariation
dir :: [Char]
dir = [Char]
"reyong"
attributeMap :: Common.AttributeMap Articulation
attributeMap :: AttributeMap Articulation
attributeMap = forall a. [(Attributes, a)] -> AttributeMap a
Common.attribute_map
[ (Attributes
cek forall a. Semigroup a => a -> a -> a
<> Attributes
loose, Articulation
CekOpen)
, (Attributes
cek, Articulation
CekClosed)
, (Attributes
mute forall a. Semigroup a => a -> a -> a
<> Attributes
loose, Articulation
MuteOpen)
, (Attributes
mute, Articulation
MuteClosed)
, (forall a. Monoid a => a
mempty, Articulation
Open)
]
where
mute :: Attributes
mute = Attributes
Attrs.mute
loose :: Attributes
loose = Attributes
Attrs.loose
cek :: Attributes
cek = Text -> Attributes
Attrs.attr Text
"cek"
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
infer :: (Note, [Note]) -> Note
infer (Note
note, [Note]
nexts) = case Note -> [Note] -> Maybe RealTime
inferEnd Note
note [Note]
nexts of
Maybe RealTime
Nothing -> Note
note
Just RealTime
end -> Note
note { duration :: RealTime
Note.duration = RealTime
end forall a. Num a => a -> a -> a
- Note -> RealTime
Note.start Note
note }
inferEnd :: Note.Note -> [Note.Note] -> Maybe RealTime
inferEnd :: Note -> [Note] -> Maybe RealTime
inferEnd Note
note [Note]
nexts = case Note -> Articulation
articulationOf Note
note of
Articulation
Open -> case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find Note -> Bool
isMute [Note]
nexts of
Maybe Note
Nothing -> forall a. a -> Maybe a
Just RealTime
Sample.forever
Just Note
mute -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Note -> RealTime
Note.start Note
mute
Articulation
CekClosed -> forall a. a -> Maybe a
Just RealTime
Sample.forever
Articulation
CekOpen -> forall a. a -> Maybe a
Just RealTime
Sample.forever
Articulation
MuteClosed -> forall a. Maybe a
Nothing
Articulation
MuteOpen -> forall a. Maybe a
Nothing
where
pitch :: Either Text (Either Pitch.Note Pitch.NoteNumber)
pitch :: Either Text (Either Note NoteNumber)
pitch = forall (m :: * -> *).
MonadError Text m =>
Note -> m (Either Note NoteNumber)
Util.symbolicPitch Note
note
isMute :: Note -> Bool
isMute Note
next =
forall (m :: * -> *).
MonadError Text m =>
Note -> m (Either Note NoteNumber)
Util.symbolicPitch Note
next forall a. Eq a => a -> a -> Bool
== Either Text (Either Note NoteNumber)
pitch Bool -> Bool -> Bool
&& case Note -> Articulation
articulationOf Note
next of
Articulation
MuteClosed -> Bool
True
Articulation
MuteOpen -> Bool
True
Articulation
_ -> Bool
False
articulationOf :: Note -> Articulation
articulationOf =
forall a. a -> AttributeMap a -> Attributes -> a
Util.articulationDefault Articulation
Open AttributeMap Articulation
attributeMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Attributes
Note.attributes
allFilenames :: Set FilePath
allFilenames :: Set [Char]
allFilenames = forall (t :: * -> *) a.
(HasCallStack, Foldable t) =>
Int -> t a -> t a
Util.assertLength Int
1440 forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList
[ Articulation -> Pitch -> Dynamic -> Int -> [Char]
toFilename Articulation
articulation Pitch
pitch Dynamic
dyn Int
variation
| Articulation
articulation <- forall a. (Enum a, Bounded a) => [a]
Util.enumAll
, Pitch
pitch <- forall k a. Map k a -> [a]
Map.elems Map NoteNumber Pitch
nnToPitch
, Dynamic
dyn <- forall a. (Enum a, Bounded a) => [a]
Util.enumAll
, Int
variation <- [Int
0 .. Articulation -> Int
variationsOf Articulation
articulation forall a. Num a => a -> a -> a
- Int
1]
]
convert :: Note.Note -> Patch.ConvertM Sample.Sample
convert :: Note -> ConvertM Sample
convert Note
note = do
let articulation :: Articulation
articulation = forall a. a -> AttributeMap a -> Attributes -> a
Util.articulationDefault Articulation
Open AttributeMap Articulation
attributeMap forall a b. (a -> b) -> a -> b
$
Note -> Attributes
Note.attributes Note
note
let (Dynamic
dyn, Y
dynVal) = forall dyn.
(Bounded dyn, Enum dyn) =>
(dyn -> (Int, Int)) -> Y -> Note -> (dyn, Y)
Util.dynamic Dynamic -> (Int, Int)
dynamicRange Y
minDyn Note
note
Either Note NoteNumber
symPitch <- forall (m :: * -> *).
MonadError Text m =>
Note -> m (Either Note NoteNumber)
Util.symbolicPitch Note
note
let var :: Int
var = Int -> Note -> Int
Util.variation (Articulation -> Int
variationsOf Articulation
articulation) Note
note
(Pitch
pitch, (NoteNumber
sampleNn, NoteNumber
noteNn)) <- forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
tryRight forall a b. (a -> b) -> a -> b
$ Either Note NoteNumber
-> Either Text (Pitch, (NoteNumber, NoteNumber))
findPitch Either Note NoteNumber
symPitch
let filename :: [Char]
filename = Articulation -> Pitch -> Dynamic -> Int -> [Char]
toFilename Articulation
articulation Pitch
pitch Dynamic
dyn Int
var
Y
dynVal <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Y
dynVal forall a. Num a => a -> a -> a
* Articulation -> Pitch -> Dynamic -> Y
tweakDynamic Articulation
articulation Pitch
pitch Dynamic
dyn
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 = if Articulation -> Bool
isMute Articulation
articulation
then forall {k} (kind :: k). Y -> Signal kind
Signal.constant Y
dynVal
else forall {k} (kind :: k). [(RealTime, Y)] -> Signal kind
Signal.from_pairs
[ (Note -> RealTime
Note.start Note
note, Y
dynVal), (Note -> RealTime
Note.end Note
note, Y
dynVal)
, (Note -> RealTime
Note.end Note
note forall a. Num a => a -> a -> a
+ RealTime
muteTime, Y
0)
]
, 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
noteNn
}
isMute :: Articulation -> Bool
isMute :: Articulation -> Bool
isMute = \case
Articulation
MuteClosed -> Bool
True
Articulation
MuteOpen -> Bool
True
Articulation
_ -> Bool
False
muteTime :: RealTime
muteTime :: RealTime
muteTime = RealTime
0.085
minDyn :: Signal.Y
minDyn :: Y
minDyn = Y
0.5
tweakDynamic :: Articulation -> Pitch -> Util.Dynamic -> Signal.Y
tweakDynamic :: Articulation -> Pitch -> Dynamic -> Y
tweakDynamic Articulation
Open (Pitch Int
5 PitchClass
I) Dynamic
Util.PP = Y
0.9
tweakDynamic Articulation
Open (Pitch Int
6 PitchClass
U) Dynamic
_ = Y
0.9
tweakDynamic Articulation
_ Pitch
_ Dynamic
_ = Y
1
toFilename :: Articulation -> Pitch -> Util.Dynamic -> Util.Variation
-> FilePath
toFilename :: Articulation -> Pitch -> Dynamic -> Int -> [Char]
toFilename Articulation
articulation Pitch
pitch Dynamic
dyn Int
variation = forall a. Monoid a => a -> [a] -> a
Lists.join [Char]
"-"
[ forall a. Show a => a -> [Char]
show (forall a. Num a => Key -> a
Midi.from_key (Pitch -> Key
pitchToKey Pitch
pitch) :: Int)
, forall a. Show a => a -> [Char]
show Int
lowVel
, forall a. Show a => a -> [Char]
show Int
highVel
, [Char]
group
] forall a. [a] -> [a] -> [a]
++ [Char]
".flac"
where
(Int
lowVel, Int
highVel) = Dynamic -> (Int, Int)
dynamicRange Dynamic
dyn
group :: [Char]
group = Articulation -> [Char]
articulationFile Articulation
articulation forall a. Semigroup a => a -> a -> a
<> [Char]
"+v" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (Int
variation forall a. Num a => a -> a -> a
+ Int
1)
articulationFile :: Articulation -> String
articulationFile :: Articulation -> [Char]
articulationFile = \case
Articulation
CekClosed -> [Char]
"cek+closed"
Articulation
CekOpen -> [Char]
"cek+open"
Articulation
MuteClosed -> [Char]
"mute+closed"
Articulation
MuteOpen -> [Char]
"mute+open"
Articulation
Open -> [Char]
"open"
findPitch :: Either Pitch.Note Pitch.NoteNumber
-> Either Text (Pitch, (Pitch.NoteNumber, Pitch.NoteNumber))
findPitch :: Either Note NoteNumber
-> Either Text (Pitch, (NoteNumber, NoteNumber))
findPitch = \case
Left (Pitch.Note Text
sym) -> do
Pitch
pitch <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust (Text
"can't parse symbolic pitch: " forall a. Semigroup a => a -> a -> a
<> Text
sym) forall a b. (a -> b) -> a -> b
$
[Char] -> Maybe Pitch
Lib.Bali.parsePitch (Text -> [Char]
untxt Text
sym)
NoteNumber
sampleNn <- forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
tryJust (Text
"pitch out of range: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Pitch
pitch) forall a b. (a -> b) -> a -> b
$
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Pitch
pitch Map Pitch NoteNumber
pitchToNn
forall (m :: * -> *) a. Monad m => a -> m a
return (Pitch
pitch, (NoteNumber
sampleNn, NoteNumber
sampleNn))
Right NoteNumber
noteNn -> forall (m :: * -> *) a. Monad m => a -> m a
return (Pitch
pitch, (NoteNumber
sampleNn, NoteNumber
noteNn))
where Just (NoteNumber
sampleNn, Pitch
pitch) = forall k v. (Ord k, Num k) => k -> Map k v -> Maybe (k, v)
Maps.lookupClosest NoteNumber
noteNn Map NoteNumber Pitch
nnToPitch
where
pitchToNn :: Map Pitch NoteNumber
pitchToNn = forall a k. Ord a => Map k a -> Map a k
Maps.invert Map NoteNumber Pitch
nnToPitch
nnToPitch :: Map Pitch.NoteNumber Pitch
nnToPitch :: Map NoteNumber Pitch
nnToPitch = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [NoteNumber]
reyongTuning forall a b. (a -> b) -> a -> b
$
forall a. Int -> [a] -> [a]
take Int
15 forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
4 [Int -> PitchClass -> Pitch
Pitch Int
oct PitchClass
pc | Int
oct <- [Int
3..], PitchClass
pc <- forall a. (Enum a, Bounded a) => [a]
Util.enumAll]
pitchToKey :: Pitch -> Midi.Key
pitchToKey :: Pitch -> Key
pitchToKey (Pitch Int
oct PitchClass
pc) = forall a. Integral a => a -> Key
Midi.to_key (Int
octforall a. Num a => a -> a -> a
*Int
12) forall a. Num a => a -> a -> a
+ PitchClass -> Key
baseKey PitchClass
pc
where
baseKey :: PitchClass -> Key
baseKey = \case
PitchClass
I -> Key
Key.c_1
PitchClass
O -> Key
Key.d_1
PitchClass
E -> Key
Key.e_1
PitchClass
U -> Key
Key.g_1
PitchClass
A -> Key
Key.a_1
reyongTuning :: [Pitch.NoteNumber]
reyongTuning :: [NoteNumber]
reyongTuning =
[ NoteNumber
56.77
, NoteNumber
60.83
, NoteNumber
62.82
, NoteNumber
63.36
, NoteNumber
67.72
, NoteNumber
68.35
, NoteNumber
72.60
, NoteNumber
74.09
, NoteNumber
75.54
, NoteNumber
79.45
, NoteNumber
80.50
, NoteNumber
84.53
, NoteNumber
86.08
, NoteNumber
87.82
, NoteNumber
91.82
]
data Articulation = CekClosed | CekOpen | MuteClosed | MuteOpen | Open
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, Articulation
forall a. a -> a -> Bounded a
maxBound :: Articulation
$cmaxBound :: Articulation
minBound :: Articulation
$cminBound :: Articulation
Bounded)
variationsOf :: Articulation -> Util.Variation
variationsOf :: Articulation -> Int
variationsOf = \case
Articulation
CekClosed -> Int
6
Articulation
CekOpen -> Int
6
Articulation
MuteClosed -> Int
4
Articulation
MuteOpen -> Int
4
Articulation
Open -> Int
4
dynamicRange :: Util.Dynamic -> (Int, Int)
dynamicRange :: Dynamic -> (Int, Int)
dynamicRange = \case
Dynamic
Util.PP -> (Int
1, Int
31)
Dynamic
Util.MP -> (Int
32, Int
64)
Dynamic
Util.MF -> (Int
65, Int
108)
Dynamic
Util.FF -> (Int
109, Int
127)