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

-- | Sonic Couture's Gamelan Bali sample set.
module User.Elaforge.Instrument.Kontakt.ScGamelan where
import qualified Data.List as List

import qualified Cmd.Instrument.Bali as Bali
import qualified Cmd.Instrument.CUtil as CUtil
import qualified Cmd.Instrument.Drums as Drums
import qualified Cmd.Instrument.MidiInst as MidiInst

import qualified Derive.Attrs as Attrs
import qualified Derive.C.Bali.Gangsa as Gangsa
import qualified Derive.EnvKey as EnvKey
import qualified Derive.Instrument.DUtil as DUtil
import qualified Derive.REnv as REnv
import qualified Derive.Scale.BaliScales as BaliScales
import qualified Derive.Scale.Legong as Legong
import qualified Derive.ScoreT as ScoreT

import qualified Instrument.Common as Common
import qualified Instrument.InstT as InstT
import qualified Midi.Key2 as Key2
import qualified Midi.Midi as Midi
import qualified Perform.Midi.Patch as Patch
import qualified Ui.UiConfig as UiConfig

import           Global


synth_name :: InstT.SynthName
synth_name :: Name
synth_name = Name
"kontakt"

patches :: [MidiInst.Patch]
patches :: [Patch]
patches = forall a b. (a -> b) -> [a] -> [b]
map Patch -> Patch
add_doc forall a b. (a -> b) -> a -> b
$
    Thru -> Maybe Control -> [(Stroke, Key)] -> Patch -> Patch
CUtil.simple_drum Thru
CUtil.MidiThru forall a. Maybe a
Nothing [(Stroke, Key)]
gong_strokes (Name -> Patch
sc_patch Name
"gong")
    forall a. a -> [a] -> [a]
: Thru -> Maybe Control -> [(Stroke, Key)] -> Patch -> Patch
CUtil.simple_drum Thru
CUtil.MidiThru forall a. Maybe a
Nothing [(Stroke, Key)]
kempli_kajar_notes
        (Name -> Patch
sc_patch Name
"kempli")
    forall a. a -> [a] -> [a]
: Patch -> Patch
reyong_ks (Range -> Name -> Patch
ranged_patch Range
Legong.reyong_range Name
"reyong")
    forall a. a -> [a] -> [a]
: Range -> Name -> Patch
ranged_patch Range
Legong.trompong_range Name
"trompong"
    forall a. a -> [a] -> [a]
: forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ Bool -> Range -> Name -> [Patch]
pasang Bool
True (Instrument -> Range
range_of Instrument
Legong.jegog) Name
"jegog"
    , Bool -> Range -> Name -> [Patch]
pasang Bool
True (Instrument -> Range
range_of Instrument
Legong.calung) Name
"calung"
    , Bool -> Range -> Name -> [Patch]
pasang Bool
True (Instrument -> Range
range_of Instrument
Legong.penyacah) Name
"penyacah"
    , [Bool -> Range -> Name -> Patch
tunggal Bool
False Range
Legong.ugal_range Name
"ugal"]
    , Bool -> Range -> Name -> [Patch]
pasang Bool
False (Instrument -> Range
range_of Instrument
Legong.pemade) Name
"pemade"
    , Bool -> Range -> Name -> [Patch]
pasang Bool
False (Instrument -> Range
range_of Instrument
Legong.kantilan) Name
"kantilan"
    ]
    where
    pasang :: Bool -> Range -> Name -> [Patch]
pasang Bool
wrap_octaves Range
range Name
name =
        [ Bool -> Range -> Name -> Patch
tunggal Bool
wrap_octaves Range
range Name
name
        , Name -> Patch -> Patch
MidiInst.dummy Name
Bali.pasang_msg forall a b. (a -> b) -> a -> b
$ Lens Patch Code
MidiInst.code forall f a. Lens f a -> a -> f -> f
#= Code
code forall a b. (a -> b) -> a -> b
$
            Range -> Name -> Patch
ranged_patch Range
range (Name
name forall a. Semigroup a => a -> a -> a
<> Name
"-pasang")
        ]
        where
        wrap :: Maybe Range
wrap = if Bool
wrap_octaves then forall a. a -> Maybe a
Just Range
range else forall a. Maybe a
Nothing
        code :: Code
code = Y -> Maybe Range -> Code
Bali.gangsa_note Y
1 Maybe Range
wrap
            forall a. Semigroup a => a -> a -> a
<> Generator Note -> Code
MidiInst.null_call Generator Note
DUtil.constant_pitch
            forall a. Semigroup a => a -> a -> a
<> Code
Bali.pasang_code
    tunggal :: Bool -> Range -> Name -> Patch
tunggal Bool
wrap_octaves Range
range Name
name =
        Lens Patch Code
MidiInst.code forall f a. Lens f a -> a -> f -> f
#= Code
code forall a b. (a -> b) -> a -> b
$ Patch -> Patch
gangsa_ks forall a b. (a -> b) -> a -> b
$ Range -> Name -> Patch
ranged_patch Range
range Name
name
        where
        wrap :: Maybe Range
wrap = if Bool
wrap_octaves then forall a. a -> Maybe a
Just Range
range else forall a. Maybe a
Nothing
        code :: Code
code = Y -> Maybe Range -> Code
Bali.gangsa_note Y
1 Maybe Range
wrap
            forall a. Semigroup a => a -> a -> a
<> Generator Note -> Code
MidiInst.null_call Generator Note
DUtil.constant_pitch

    range_of :: Instrument -> Range
range_of = Instrument -> Range
BaliScales.instrument_range
    ranged_patch :: Range -> Name -> Patch
ranged_patch Range
range = Range -> Patch -> Patch
MidiInst.range Range
range forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Patch
sc_patch
    sc_patch :: Name -> Patch
sc_patch Name
name =
        Patch :-> Patch
MidiInst.patch forall f a. Lens f a -> (a -> a) -> f -> f
%= [Flag] -> Patch -> Patch
MidiInst.add_flags [Flag
Patch.UseFinalNoteOff] forall a b. (a -> b) -> a -> b
$
        PbRange -> Name -> [(Channel, Control)] -> Patch
MidiInst.named_patch (-Int
2, Int
2) (Name
"sc-" forall a. Semigroup a => a -> a -> a
<> Name
name) []
    add_doc :: Patch -> Patch
add_doc = Lens Patch Doc
MidiInst.doc
        forall f a. Lens f a -> (a -> a) -> f -> f
%= (Doc
"Sonic Couture's Balinese gamelan sample set. " <>)
    gangsa_ks :: Patch -> Patch
gangsa_ks = Lens Patch AttributeMap
MidiInst.attribute_map forall f a. Lens f a -> a -> f -> f
#= [(Attributes, Key)] -> AttributeMap
Patch.single_keyswitches
        [(Attributes
Attrs.mute, Key
Key2.cs1), (forall a. Monoid a => a
mempty, Key
Key2.c1)]
    reyong_ks :: Patch -> Patch
reyong_ks = Lens Patch AttributeMap
MidiInst.attribute_map forall f a. Lens f a -> a -> f -> f
#= [(Attributes, Key)] -> AttributeMap
Patch.single_keyswitches
        [(Name -> Attributes
Attrs.attr Name
"cek", Key
Key2.cs1), (forall a. Monoid a => a
mempty, Key
Key2.c1)]
    gong_strokes :: [(Stroke, Key)]
gong_strokes =
        [ (Char -> Symbol -> Attributes -> Stroke
n Char
'z' Symbol
"O" (Attributes
gong forall a. Semigroup a => a -> a -> a
<> Attributes
wadon),   Key
Key2.b1)
        , (Char -> Symbol -> Attributes -> Stroke
n Char
'x' Symbol
"o" (Attributes
gong forall a. Semigroup a => a -> a -> a
<> Attributes
lanang),  Key
Key2.c2)
        , (Char -> Symbol -> Attributes -> Stroke
n Char
'q' Symbol
"p" Attributes
kempur,            Key
Key2.a2)
        , (Char -> Symbol -> Attributes -> Stroke
n Char
'w' Symbol
"m" Attributes
kemong,            Key
Key2.a3)
        ]
        where n :: Char -> Symbol -> Attributes -> Stroke
n = Char -> Symbol -> Attributes -> Stroke
Drums.stroke
    kempli_kajar_notes :: [(Stroke, Key)]
kempli_kajar_notes =
        [ (Char -> Symbol -> Attributes -> Stroke
n Char
'z' Symbol
"+"    Attributes
kempli,                 Key
Key2.d3)
        , (Char -> Symbol -> Attributes -> Stroke
n Char
'a' Symbol
"`O+`" (Attributes
kempli forall a. Semigroup a => a -> a -> a
<> Attributes
open),       Key
Key2.ds3)
        , (Char -> Symbol -> Attributes -> Stroke
n Char
'x' Symbol
"+1"   (Attributes
kempli forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.v1),   Key
Key2.f3)
        , (Char -> Symbol -> Attributes -> Stroke
n Char
'c' Symbol
"+2"   (Attributes
kempli forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.v2),   Key
Key2.g3)
        , (Char -> Symbol -> Attributes -> Stroke
n Char
'v' Symbol
"+3"   (Attributes
kempli forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.v3),   Key
Key2.a3)
        , (Char -> Symbol -> Attributes -> Stroke
n Char
'b' Symbol
"b"    Attributes
bebende,                Key
Key2.d4)
        , (Char -> Symbol -> Attributes -> Stroke
n Char
'g' Symbol
"B"    (Attributes
bebende forall a. Semigroup a => a -> a -> a
<> Attributes
open),      Key
Key2.ds4)
        , (Char -> Symbol -> Attributes -> Stroke
n Char
'q' Symbol
"o"    Attributes
kajar,                  Key
Key2.f4)
        , (Char -> Symbol -> Attributes -> Stroke
n Char
'w' Symbol
"+"    (Attributes
kajar forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.rim forall a. Semigroup a => a -> a -> a
<> Attributes
open), Key
Key2.fs4)
        -- The Sonic Couture kajar doesn't have this.
        , (Char -> Symbol -> Attributes -> Stroke
n Char
'e' Symbol
"P"    (Attributes
kajar forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.rim),   Key
Key2.g4)
        -- Soniccouture also has a low kajar variant.
        ]
        where n :: Char -> Symbol -> Attributes -> Stroke
n = Char -> Symbol -> Attributes -> Stroke
Drums.stroke
    open :: Attributes
open = Attributes
Attrs.open

gong :: Attributes
gong = Name -> Attributes
Attrs.attr Name
"gong"
kemong :: Attributes
kemong = Name -> Attributes
Attrs.attr Name
"kemong"
kempur :: Attributes
kempur = Name -> Attributes
Attrs.attr Name
"kempur"
bebende :: Attributes
bebende = Name -> Attributes
Attrs.attr Name
"bebende"
wadon :: Attributes
wadon = Name -> Attributes
Attrs.attr Name
"wadon"
lanang :: Attributes
lanang = Name -> Attributes
Attrs.attr Name
"lanang"
kempli :: Attributes
kempli = Name -> Attributes
Attrs.attr Name
"kempli"
kajar :: Attributes
kajar = Name -> Attributes
Attrs.attr Name
"kajar"

kebyar_allocations :: Text -> UiConfig.Allocations
kebyar_allocations :: Name -> Allocations
kebyar_allocations Name
dev_ = [(Instrument, Qualified, Bool, [(Name, Val)], Maybe Scale)]
-> Allocations
make_config forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ Name -> [(Instrument, Qualified, Bool, [(Name, Val)], Maybe Scale)]
pasang Name
"jegog"
    , Name -> [(Instrument, Qualified, Bool, [(Name, Val)], Maybe Scale)]
pasang Name
"calung"
    , Name -> [(Instrument, Qualified, Bool, [(Name, Val)], Maybe Scale)]
pasang Name
"penyacah"
    , Name -> [(Instrument, Qualified, Bool, [(Name, Val)], Maybe Scale)]
pasang Name
"pemade"
    , Name -> [(Instrument, Qualified, Bool, [(Name, Val)], Maybe Scale)]
pasang Name
"kantilan"
    , [ forall {a}.
a -> Name -> (a, Qualified, Bool, [(Name, Val)], Maybe Scale)
umbang_patch Instrument
"ugal" Name
"ugal"
      , forall {a}.
a -> Name -> (a, Qualified, Bool, [(Name, Val)], Maybe Scale)
isep_patch Instrument
"reyong" Name
"reyong"
      , forall {a}.
a -> Name -> (a, Qualified, Bool, [(Name, Val)], Maybe Scale)
umbang_patch Instrument
"trompong" Name
"trompong"
      , forall {a} {a}. Name -> (Instrument, Qualified, Bool, [a], Maybe a)
patch Name
"gong"
      , forall {a} {a}. Name -> (Instrument, Qualified, Bool, [a], Maybe a)
patch Name
"kempli"
      ]
    ]
    where
    -- (inst, qualified, gets_chan, environ, scale)
    make_config :: [(ScoreT.Instrument, InstT.Qualified, Bool,
            [(EnvKey.Key, REnv.Val)], Maybe Patch.Scale)]
        -> UiConfig.Allocations
    make_config :: [(Instrument, Qualified, Bool, [(Name, Val)], Maybe Scale)]
-> Allocations
make_config = [(Instrument, Qualified, Config -> Config, Backend)] -> Allocations
MidiInst.allocations forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL forall {a} {b}.
Channel
-> (a, b, Bool, [(Name, Val)], Maybe Scale)
-> (Channel, (a, b, Config -> Config, Backend))
allocate Channel
0
        where
        allocate :: Channel
-> (a, b, Bool, [(Name, Val)], Maybe Scale)
-> (Channel, (a, b, Config -> Config, Backend))
allocate Channel
chan (a
inst, b
qualified, Bool
gets_chan, [(Name, Val)]
environ, Maybe Scale
scale) =
            ( Channel
next_chan
            , (a
inst, b
qualified, Config -> Config
set_config, Backend
backend)
            )
            where
            next_chan :: Channel
next_chan = if Bool
gets_chan then Channel
chanforall a. Num a => a -> a -> a
+Channel
1 else Channel
chan
            backend :: Backend
backend
                | Bool
gets_chan = Config -> Backend
UiConfig.Midi forall a b. (a -> b) -> a -> b
$
                    Config :-> Settings
Patch.settingsforall a b c. Lens a b -> Lens b c -> Lens a c
#Settings :-> Maybe Scale
Patch.scale forall f a. Lens f a -> a -> f -> f
#= Maybe Scale
scale forall a b. (a -> b) -> a -> b
$
                    WriteDevice -> Channel -> Config
MidiInst.config1 WriteDevice
dev Channel
chan
                -- Pasang instruments don't get an allocation.  Otherwise they
                -- don't have the right tuning.
                | Bool
otherwise = Name -> Backend
UiConfig.Dummy Name
""
            set_config :: Config -> Config
set_config = Config :-> Environ
Common.cenviron forall f a. Lens f a -> a -> f -> f
#= [(Name, Val)] -> Environ
REnv.from_list [(Name, Val)]
environ
    dev :: WriteDevice
dev = Name -> WriteDevice
Midi.write_device Name
dev_

    -- Actually pemade and kantilan have an umbang isep pair for both polos and
    -- sangsih, but since I don't have that many sample sets I have
    -- a mini-ensemble with only one pair of each gangsa.
    pasang :: Name -> [(Instrument, Qualified, Bool, [(Name, Val)], Maybe Scale)]
pasang Name
name =
        [ ( Name -> Instrument
ScoreT.Instrument Name
name, Name -> Qualified
sc_qualified (Name
name forall a. Semigroup a => a -> a -> a
<> Name
"-pasang")
          , Bool
False, Name -> [(Name, Val)]
polos_sangsih Name
name, forall a. Maybe a
Nothing
          )
        , forall {a}.
a -> Name -> (a, Qualified, Bool, [(Name, Val)], Maybe Scale)
umbang_patch (Name -> Instrument
ScoreT.Instrument forall a b. (a -> b) -> a -> b
$ Name
name forall a. Semigroup a => a -> a -> a
<> Name
"-p") Name
name
        , forall {a}.
a -> Name -> (a, Qualified, Bool, [(Name, Val)], Maybe Scale)
isep_patch (Name -> Instrument
ScoreT.Instrument forall a b. (a -> b) -> a -> b
$ Name
name forall a. Semigroup a => a -> a -> a
<> Name
"-s") Name
name
        ]
    sc_qualified :: Name -> Qualified
sc_qualified Name
name = Name -> Name -> Qualified
InstT.Qualified Name
synth_name (Name
"sc-" forall a. Semigroup a => a -> a -> a
<> Name
name)
    polos_sangsih :: Name -> [(Name, Val)]
polos_sangsih Name
name =
        [ (Name
Gangsa.inst_polos, forall a. ToVal a => a -> Val
REnv.to_val forall a b. (a -> b) -> a -> b
$ Name -> Instrument
ScoreT.Instrument forall a b. (a -> b) -> a -> b
$ Name
name forall a. Semigroup a => a -> a -> a
<> Name
"-p")
        , (Name
Gangsa.inst_sangsih, forall a. ToVal a => a -> Val
REnv.to_val forall a b. (a -> b) -> a -> b
$ Name -> Instrument
ScoreT.Instrument forall a b. (a -> b) -> a -> b
$ Name
name forall a. Semigroup a => a -> a -> a
<> Name
"-s")
        ]
    umbang_patch :: a -> Name -> (a, Qualified, Bool, [(Name, Val)], Maybe Scale)
umbang_patch a
name Name
patch =
        ( a
name, Name -> Qualified
sc_qualified Name
patch, Bool
True
        , forall {a}. ToVal a => a -> [(Name, Val)]
tuning Tuning
BaliScales.Umbang
        , forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Laras -> Tuning -> Scale
Legong.complete_instrument_scale
            Laras
Legong.laras_rambat Tuning
BaliScales.Umbang
        )
    isep_patch :: a -> Name -> (a, Qualified, Bool, [(Name, Val)], Maybe Scale)
isep_patch a
name Name
patch =
        ( a
name, Name -> Qualified
sc_qualified Name
patch, Bool
True
        , forall {a}. ToVal a => a -> [(Name, Val)]
tuning Tuning
BaliScales.Isep
        , forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Laras -> Tuning -> Scale
Legong.complete_instrument_scale
            Laras
Legong.laras_rambat Tuning
BaliScales.Isep
        )
    tuning :: a -> [(Name, Val)]
tuning a
val = [(Name
EnvKey.tuning, forall a. ToVal a => a -> Val
REnv.to_val a
val)]
    patch :: Name -> (Instrument, Qualified, Bool, [a], Maybe a)
patch Name
name = (Name -> Instrument
ScoreT.Instrument Name
name, Name -> Qualified
sc_qualified Name
name, Bool
True, [], forall a. Maybe a
Nothing)