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

-- | Kendang sunda patches for "User.Elaforge.Instrument.Kontakt".
module User.Elaforge.Instrument.Kontakt.KendangSunda (
    patches, write_ksp, pitch_control
    , resolve_errors
) where
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.Prelude.Note as Note
import qualified Derive.Call as Call
import qualified Derive.Call.Module as Module
import qualified Derive.Call.Tags as Tags
import qualified Derive.Derive as Derive
import qualified Derive.Expr as Expr
import qualified Derive.ScoreT as ScoreT
import qualified Derive.Sig as Sig

import qualified Midi.Key as Key
import qualified User.Elaforge.Instrument.Kontakt.Util as Util

import           Global


patches :: [MidiInst.Patch]
patches :: [Patch]
patches =
    [ Lens Patch Code
MidiInst.code forall f a. Lens f a -> a -> f -> f
#= Code
code forall a b. (a -> b) -> a -> b
$ PitchedStrokes -> Patch -> Patch
CUtil.pitched_drum_patch PitchedStrokes
pitched_strokes forall a b. (a -> b) -> a -> b
$
        Text -> Patch
patch Text
"kendang-sunda"
    ]
    where
    patch :: Text -> Patch
patch Text
name = PbRange -> Text -> [(Control, Control)] -> Patch
MidiInst.named_patch (-Int
24, Int
24) Text
name [(Control
4, Control
pitch_control)]
    strokes :: [Stroke]
strokes = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst PitchedStrokes
pitched_strokes
    code :: Code
code = HandlerId -> Code
MidiInst.cmd (forall (m :: * -> *).
M m =>
[(Char, Symbol)] -> Thru -> [Stroke] -> Handler m
CUtil.drum_cmd [] Thru
CUtil.MidiThru [Stroke]
strokes)
        forall a. Semigroup a => a -> a -> a
<> [(Symbol, Generator Note)] -> Code
MidiInst.note_generators
            ([(Symbol, Generator Note)] -> [(Symbol, Generator Note)]
replace_det forall a b. (a -> b) -> a -> b
$ [(Stroke, CallConfig)] -> [(Symbol, Generator Note)]
CUtil.drum_calls (forall a b. (a -> b) -> [a] -> [b]
map (,CallConfig
call_config) [Stroke]
strokes))

replace_det :: [(Expr.Symbol, Derive.Generator Derive.Note)]
    -> [(Expr.Symbol, Derive.Generator Derive.Note)]
replace_det :: [(Symbol, Generator Note)] -> [(Symbol, Generator Note)]
replace_det = ([(Symbol, Generator Note)]
calls++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Symbol, Generator Note)]
calls) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
    where
    calls :: [(Symbol, Generator Note)]
calls =
        [ (Symbol
"o", Generator Note
c_dong)
        , (Symbol
"e", Maybe Pitch -> Generator Note
c_det forall a. Maybe a
Nothing)
        , (Symbol
"e_", Maybe Pitch -> Generator Note
c_det (forall a. a -> Maybe a
Just Pitch
Low))
        , (Symbol
"e-", Maybe Pitch -> Generator Note
c_det (forall a. a -> Maybe a
Just Pitch
Middle))
        , (Symbol
"e^", Maybe Pitch -> Generator Note
c_det (forall a. a -> Maybe a
Just Pitch
High))
        ]

-- | Just like the default, except force 'pitch_control' to 0.
c_dong :: Derive.Generator Derive.Note
c_dong :: Generator Note
c_dong = CallConfig -> Symbol -> Attributes -> Generator Note
CUtil.drum_call CallConfig
config Symbol
"o" Attributes
dong
    where
    config :: CallConfig
config = CallConfig
call_config
        { _transform :: NoteDeriver -> NoteDeriver
CUtil._transform = forall a. Control -> Y -> Deriver a -> Deriver a
Derive.with_constant_control Control
pitch_control Y
0 }

call_config :: CUtil.CallConfig
call_config :: CallConfig
call_config = CallConfig
CUtil.call_config { _tuning_control :: Maybe Control
CUtil._tuning_control = forall a. a -> Maybe a
Just Control
tuning_control }

data Pitch = Low | Middle | High deriving (Int -> Pitch -> ShowS
[Pitch] -> ShowS
Pitch -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pitch] -> ShowS
$cshowList :: [Pitch] -> ShowS
show :: Pitch -> String
$cshow :: Pitch -> String
showsPrec :: Int -> Pitch -> ShowS
$cshowsPrec :: Int -> Pitch -> ShowS
Show)

-- | Like the default, except set @+dong@ and force 'pitch_control' if Pitch is
-- given.  Of course, I could also set +det+low etc. and it would work with
-- integration.  Ok, so don't change the attrs, but set the control and have
-- separate defaults.
c_det :: Maybe Pitch -> Derive.Generator Derive.Note
c_det :: Maybe Pitch -> Generator Note
c_det Maybe Pitch
vague_pitch = forall d.
Module
-> CallName
-> Tags
-> Doc
-> WithArgDoc (GeneratorF d)
-> Generator d
Derive.generator Module
Module.instrument CallName
name Tags
Tags.attr Doc
doc forall a b. (a -> b) -> a -> b
$
    forall y a d.
Taggable y =>
Parser a -> (a -> Generator y d) -> WithArgDoc (Generator y d)
Sig.call (
        forall a deflt.
(Typecheck a, ToVal deflt) =>
ArgName -> EnvironDefault -> deflt -> Doc -> Parser a
Sig.defaulted_env ArgName
"pitch" EnvironDefault
Derive.Unprefixed Y
pitch_default
            Doc
"0 is the open pitch, and 1 is the highest pitch."
    ) forall a b. (a -> b) -> a -> b
$ \Y
pitch PassedArgs Note
args -> forall d. Attributes -> Deriver d -> Deriver d
Call.add_attributes Attributes
attrs forall a b. (a -> b) -> a -> b
$
        forall a. PassedArgs Note -> Control -> Deriver a -> Deriver a
CUtil.apply_tuning_control PassedArgs Note
args Control
tuning_control forall a b. (a -> b) -> a -> b
$
        forall a. Control -> Y -> Deriver a -> Deriver a
Derive.with_constant_control Control
pitch_control Y
pitch forall a b. (a -> b) -> a -> b
$
        Config -> Generator Note (Stream Note)
Note.default_note Config
Note.no_duration_attributes PassedArgs Note
args
    where
    doc :: Doc
doc = Doc
"This takes a pitch argument and is split into separate calls so\
        \ there can be separate defaults for low, middle, and high."
    name :: CallName
name = case Maybe Pitch
vague_pitch of
        Maybe Pitch
Nothing -> CallName
"det"
        Just Pitch
Low -> CallName
"det-low"
        Just Pitch
Middle -> CallName
"det-mid"
        Just Pitch
High -> CallName
"det-high"
    pitch_default :: Double
    pitch_default :: Y
pitch_default = case Maybe Pitch
vague_pitch of
        Maybe Pitch
Nothing -> Y
0.5
        Just Pitch
Low -> Y
0.25
        Just Pitch
Middle -> Y
0.5
        Just Pitch
High -> Y
0.75
    attrs :: Attributes
attrs = Attributes
det forall a. Semigroup a => a -> a -> a
<> case Maybe Pitch
vague_pitch of
        Maybe Pitch
Nothing -> forall a. Monoid a => a
mempty
        Just Pitch
Low -> Attributes
Attrs.low
        Just Pitch
Middle -> Attributes
Attrs.middle
        Just Pitch
High -> Attributes
Attrs.high

tuning_control :: ScoreT.Control
tuning_control :: Control
tuning_control = Control
"kendang-tune"

pitch_control :: ScoreT.Control
pitch_control :: Control
pitch_control = Control
"pitch"

pitched_strokes :: CUtil.PitchedStrokes
(PitchedStrokes
pitched_strokes, [Text]
resolve_errors) = Y
-> Map Attributes KeyswitchRange
-> [(Char, Symbol, Attributes, Text)]
-> (PitchedStrokes, [Text])
CUtil.resolve_strokes Y
0.3 Map Attributes KeyswitchRange
keymap [(Char, Symbol, Attributes, Text)]
strokes

strokes :: [(Char, Expr.Symbol, Attrs.Attributes, Drums.Group)]
stops :: [(Drums.Group, [Drums.Group])]
([(Text, [Text])]
stops, [(Char, Symbol, Attributes, Text)]
strokes) = (,) [(Text, [Text])]
stops
    -- TODO paired strokes:
    -- bang = dong + pak, plang = tong + pak, blang = dong + peung
    -- plak = tak + phak
    --
    -- with panggul
    -- indung, kiri
    [ (Char
'a', Symbol
"-",    Attributes
tak forall a. Semigroup a => a -> a -> a
<> Attributes
soft,        Text
left_closed)
    , (Char
'z', Symbol
"+",    Attributes
tak,                Text
left_closed)
    , (Char
's', Symbol
".",    Attributes
dong forall a. Semigroup a => a -> a -> a
<> Attributes
soft,       Text
left_open)
    , (Char
'x', Symbol
"o",    Attributes
dong,               Text
left_open)
    , (Char
'c', Symbol
"i",    Attributes
ting,               Text
left_semiclosed)
    -- This uses the %pitch control.
    , (Char
'v', Symbol
"e",    Attributes
det,                Text
left_semiclosed)
    -- These are hardcoded to a certain pitch.
    , (Char
'b', Symbol
"e_",   Attributes
det forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.low,   Text
left_semiclosed)
    , (Char
'n', Symbol
"e-",   Attributes
det forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.middle,Text
left_semiclosed)
    , (Char
'm', Symbol
"e^",   Attributes
det forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.high,  Text
left_semiclosed)
    -- kulanter gede
    , (Char
',', Symbol
"u",    Attributes
tung,               Text
kulanter_gede_open)
    -- indung, kanan
    , (Char
'1', Symbol
"^",    Attributes
phak forall a. Semigroup a => a -> a -> a
<> Attributes
soft,       Text
right_closed)
    , (Char
'q', Symbol
"P",    Attributes
phak,               Text
right_closed)
    , (Char
'2', Symbol
"'",    Attributes
phak1 forall a. Semigroup a => a -> a -> a
<> Attributes
soft,      Text
right_closed)
    , (Char
'w', Symbol
"T",    Attributes
phak1,              Text
right_closed)
    , (Char
'e', Symbol
"I",    Attributes
ping,               Text
right_open)
    , (Char
'r', Symbol
"O",    Attributes
pong,               Text
right_open)
    -- kulanter leutik
    , (Char
't', Symbol
"K",    Attributes
pak,                Text
kulanter_leutik_closed)
    , (Char
'y', Symbol
"E",    Attributes
peung,              Text
kulanter_leutik_open)
    ]
    where
    soft :: Attributes
soft = Attributes
Attrs.soft
    stops :: [(Text, [Text])]
stops =
        [ (Text
left_closed, [Text
left_open])
        -- TODO this should be (left_semiclosed, [left_open, left_semiclosed]),
        -- but the ksp doesn't understand cc switching.
        , (Text
left_open, [Text
left_open])
        , (Text
right_closed, [Text
right_open])
        , (Text
kulanter_leutik_closed, [Text
kulanter_leutik_open])
        ]
    left_open :: Text
left_open = Text
"left-open"
    -- TODO this should be its own group, but the ksp doesn't understand cc
    -- switching.
    left_semiclosed :: Text
left_semiclosed = Text
"left-open"
    left_closed :: Text
left_closed = Text
"left-closed"

    right_open :: Text
right_open = Text
"right-open"
    right_closed :: Text
right_closed = Text
"right-closed"
    kulanter_gede_open :: Text
kulanter_gede_open = Text
"kulanter-gede-open"
    kulanter_leutik_closed :: Text
kulanter_leutik_closed = Text
"kulanter-leutik-closed"
    kulanter_leutik_open :: Text
kulanter_leutik_open = Text
"kulanter-leutik-open"

keymap :: Map Attrs.Attributes CUtil.KeyswitchRange
keymap :: Map Attributes KeyswitchRange
keymap = Maybe Key
-> Key
-> Key
-> Key
-> Key
-> [[Attributes]]
-> Map Attributes KeyswitchRange
CUtil.make_keymap2 forall a. Maybe a
Nothing Key
8 Key
6 Key
12 Key
Key.c4
    -- indung, left
    [ [Attributes
dong, Attributes
det, Attributes
det forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.low, Attributes
det forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.middle, Attributes
det forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.high]
    , [Attributes
ting]
    , [Attributes
tak] -- closed

    -- indung, right
    , [Attributes
phak]
    , [Attributes
phak1] -- phak with one finger
    , [Attributes
ping]
    , [Attributes
pong]
    -- kulanter gede
    , [Attributes
tung]
    -- kulanter leutik
    , [Attributes
pak]
    , [Attributes
peung]
    ]

write_ksp :: IO ()
write_ksp :: IO ()
write_ksp = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Either Text Text -> IO ()
Util.write)
    [ (String
"kendang-sunda.ksp",
        Text -> PitchedStrokes -> [(Text, [Text])] -> Either Text Text
Util.drum_mute_ksp Text
"kendang sunda" PitchedStrokes
pitched_strokes [(Text, [Text])]
stops)
    ]

-- indung, kiri

-- | Open left hand stroke, low pitch.
dong :: Attrs.Attributes
dong :: Attributes
dong = Text -> Attributes
Attrs.attr Text
"dong"

-- | Open left hand stroke, high pitch.
det :: Attrs.Attributes
det :: Attributes
det = Text -> Attributes
Attrs.attr Text
"det"

-- | Right side harmonic played on the left hand.
ting :: Attrs.Attributes
ting :: Attributes
ting = Text -> Attributes
Attrs.attr Text
"ting"

-- | Closed left hand stroke.  This isn't an official name.
tak :: Attrs.Attributes
tak :: Attributes
tak = Text -> Attributes
Attrs.attr Text
"tak"

-- indung, kanan

-- | Open right hand stroke.
ping :: Attrs.Attributes
ping :: Attributes
ping = Text -> Attributes
Attrs.attr Text
"ping"

-- | Open right hand rim.
pong :: Attrs.Attributes
pong :: Attributes
pong = Text -> Attributes
Attrs.attr Text
"pong"

-- | Closed right hand stroke.
phak :: Attrs.Attributes
phak :: Attributes
phak = Text -> Attributes
Attrs.attr Text
"phak"

-- | Phak with one finger.
phak1 :: Attrs.Attributes
phak1 :: Attributes
phak1 = Text -> Attributes
Attrs.attr Text
"phak1"

-- | Kulanter gede, open stroke.
tung :: Attrs.Attributes
tung :: Attributes
tung = Text -> Attributes
Attrs.attr Text
"tung"

-- | Kulanter leutik, closed stroke.
pak :: Attrs.Attributes
pak :: Attributes
pak = Text -> Attributes
Attrs.attr Text
"pak"

-- | Kulanter leutik, open stroke.
peung :: Attrs.Attributes
peung :: Attributes
peung = Text -> Attributes
Attrs.attr Text
"peung"