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

-- | Spicy guitar, free at http://www.spicyguitar.com/
module User.Elaforge.Instrument.Spicy where
import qualified Data.Text as Text

import qualified Util.Doc as Doc
import qualified Util.Lists as Lists
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.Derive as Derive
import qualified Derive.ScoreT as ScoreT

import qualified Instrument.InstT as InstT
import qualified Midi.Key as Key
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 :: Text
synth_name = Text
"spicy"

synth :: MidiInst.Synth
synth :: Synth
synth = Text -> Text -> [Patch] -> Synth
MidiInst.synth Text
synth_name Text
"Spicy Guitar, http://www.spicyguitar.com" forall a b. (a -> b) -> a -> b
$
    [(Control, Control)] -> [Patch] -> [Patch]
MidiInst.synth_controls [(Control, Control)]
controls [Patch]
patches

patches :: [MidiInst.Patch]
patches :: [Patch]
patches = (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$
    Lens Patch Code
MidiInst.code forall f a. Lens f a -> a -> f -> f
#= Generator Note -> Code
MidiInst.null_call Generator Note
note_call forall a b. (a -> b) -> a -> b
$
    Patch -> Patch
MidiInst.make_patch forall a b. (a -> b) -> a -> b
$
    Flag -> Patch -> Patch
MidiInst.add_flag Flag
Patch.HoldKeyswitch forall a b. (a -> b) -> a -> b
$
    Patch :-> AttributeMap
Patch.attribute_map forall f a. Lens f a -> a -> f -> f
#= [(Attributes, Key)] -> AttributeMap
Patch.single_keyswitches [(Attributes, Key)]
keyswitches forall a b. (a -> b) -> a -> b
$
    PbRange -> Text -> Patch
Patch.patch (-Int
3, Int
3) Text
Patch.default_name


-- | WARNING: changing these while playing tends to crash the VST.
controls :: [(Midi.Control, ScoreT.Control)]
controls :: [(Control, Control)]
controls =
    [ (Control
20, Control
"position") -- 0 for bridge, 1 for middle
    , (Control
21, Control
"finger") -- 0 for finger plucking, 1 for pick
    , (Control
22, Control
"inharmonicity")
    , (Control
23, Control
"twang")
    , (Control
24, Control
"color")
    , (Control
25, Control
"impedance")
    , (Control
26, Control
"vibrato") -- speed of vibrato
    , (Control
27, Control
"mute") -- amount of palm mute effect
    , (Control
28, Control
"harm")
    ]

keyswitches :: [(Attrs.Attributes, Midi.Key)]
keyswitches :: [(Attributes, Key)]
keyswitches =
    [ (Attributes
Attrs.legato, Key
Key.b2)
    , (Attributes
Attrs.mute, Key
Key.c3)
    , (Attributes
Attrs.harm, Key
Key.cs3)
    ]

note_call :: Derive.Generator Derive.Note
note_call :: Generator Note
note_call = Doc
-> Tags
-> (NoteArgs -> NoteDeriver -> NoteDeriver)
-> Generator Note
Note.transformed_note
    (Doc
"If given a string-name attribute in " forall a. Semigroup a => a -> a -> a
<> Doc
attrs_doc forall a. Semigroup a => a -> a -> a
<> Doc
", suffix the"
        forall a. Semigroup a => a -> a -> a
<> Doc
" instrument with the string name.  When combined with the proper"
        forall a. Semigroup a => a -> a -> a
<> Doc
" midi config, this will redirect the note to the proper channel"
        forall a. Semigroup a => a -> a -> a
<> Doc
" for that string.") forall a. Monoid a => a
mempty
    (forall a b. a -> b -> a
const forall {b}. Deriver b -> Deriver b
transform)
    where
    attrs_doc :: Doc
attrs_doc = Text -> Doc
Doc.Doc forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
Text.intercalate Text
", " [Text
"`" forall a. Semigroup a => a -> a -> a
<> Text
a forall a. Semigroup a => a -> a -> a
<> Text
"`" | Text
a <- [Text]
strings]
    transform :: Deriver b -> Deriver b
transform Deriver b
deriver = do
        Attributes
attrs <- Deriver Attributes
Call.get_attributes
        Maybe Instrument
inst <- Deriver (Maybe Instrument)
Call.lookup_instrument
        let string :: Maybe Text
string = forall a. [a] -> Maybe a
Lists.head
                [ Text
string
                | Text
attr <- Attributes -> [Text]
Attrs.to_list Attributes
attrs, Text
string <- [Text]
strings
                , Text
attr forall a. Eq a => a -> a -> Bool
== Text
string
                ]
        case (Maybe Instrument
inst, Maybe Text
string) of
            (Just Instrument
inst, Just Text
string) ->
                forall d. Instrument -> Deriver d -> Deriver d
Derive.with_instrument (Instrument -> Text -> Instrument
string_inst Instrument
inst Text
string) Deriver b
deriver
            (Maybe Instrument, Maybe Text)
_ -> Deriver b
deriver
    string_inst :: Instrument -> Text -> Instrument
string_inst Instrument
inst Text
string =
        Text -> Instrument
ScoreT.Instrument forall a b. (a -> b) -> a -> b
$ Instrument -> Text
ScoreT.instrument_name Instrument
inst forall a. Semigroup a => a -> a -> a
<> Text
"-" forall a. Semigroup a => a -> a -> a
<> Text
string

strings :: [Text]
strings :: [Text]
strings = [Text
"e1", Text
"a", Text
"d", Text
"g", Text
"b", Text
"e2"]

-- | Create the proper midi config to work with the string attrs used by
-- 'note_call'.
allocations :: Text -> InstT.Name -> UiConfig.Allocations
allocations :: Text -> Text -> Allocations
allocations Text
dev_name Text
name = [(Instrument, (Qualified, Config))] -> Allocations
UiConfig.midi_allocations forall a b. (a -> b) -> a -> b
$
    Text -> Control -> (Instrument, (Qualified, Config))
inst Text
name Control
0 forall a. a -> [a] -> [a]
: [Text -> Control -> (Instrument, (Qualified, Config))
inst (Text
name forall a. Semigroup a => a -> a -> a
<> Text
"-" forall a. Semigroup a => a -> a -> a
<> Text
string) Control
chan
        | (Text
string, Control
chan) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
strings [Control
1..]]
    where
    inst :: Text -> Control -> (Instrument, (Qualified, Config))
inst Text
name Control
chan =
        ( Text -> Instrument
ScoreT.Instrument Text
name
        , (Text -> Text -> Qualified
InstT.Qualified Text
synth_name Text
name, WriteDevice -> Control -> Config
MidiInst.config1 WriteDevice
dev Control
chan)
        )
    dev :: WriteDevice
dev = Text -> WriteDevice
Midi.write_device Text
dev_name