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

-- | Instrument definitions for mridangam.  These are shared between multiple
-- mridangam definitions.
module Cmd.Instrument.Mridangam where
import           Prelude hiding (min, tan)
import qualified Data.Char as Char
import qualified Data.Text as Text

import qualified Cmd.Instrument.CUtil as CUtil
import qualified Cmd.Instrument.Drums as Drums
import qualified Cmd.Instrument.ImInst as ImInst

import qualified Derive.Attrs as Attrs
import qualified Derive.Call.Make as Make
import qualified Derive.Call.Module as Module
import qualified Derive.Derive as Derive
import qualified Derive.Expr as Expr
import qualified Derive.Instrument.DUtil as DUtil
import qualified Derive.PSignal as PSignal

import qualified Perform.Pitch as Pitch

import           Global


-- * mridangam

code :: CUtil.Thru -> Pitch.NoteNumber
    -> Maybe (Derive.TransformerF Derive.Note) -> ImInst.Code
code :: Thru -> NoteNumber -> Maybe (TransformerF Note) -> Code
code Thru
thru NoteNumber
natural_nn Maybe (TransformerF Note)
transform =
    Thru
-> [Attributes]
-> NoteNumber
-> Maybe (TransformerF Note)
-> [Stroke]
-> [(Symbol, [Symbol], Maybe Char)]
-> Code
make_code Thru
thru [Attributes]
pitched_strokes NoteNumber
natural_nn Maybe (TransformerF Note)
transform [Stroke]
all_strokes [(Symbol, [Symbol], Maybe Char)]
both_calls

-- | Single symbols for two strokes together.  thom+x becomes a capital X,
-- and there are a few ad-hoc capital letters for more common tha+x
-- combinations.
both_calls :: [(Expr.Symbol, [Expr.Symbol], Maybe Char)]
both_calls :: [(Symbol, [Symbol], Maybe Char)]
both_calls = [Stroke]
-> [Stroke]
-> [(Symbol, [Symbol])]
-> [(Symbol, Char)]
-> [(Symbol, [Symbol], Maybe Char)]
make_both [Stroke]
left_notes [Stroke]
right_notes [(Symbol, [Symbol])]
special_names
    [ (Symbol
"N", Char
'g'), (Symbol
"D", Char
'b')
    , (Symbol
"K", Char
'h'), (Symbol
"T", Char
'n')
    , (Symbol
"P", Char
'j'), (Symbol
"X", Char
'm')
    ]
    where
    special_names :: [(Symbol, [Symbol])]
special_names = [(Symbol
"P", [Symbol
"*", Symbol
"k"]), (Symbol
"X", [Symbol
"*", Symbol
"t"])]
        forall a. [a] -> [a] -> [a]
++ [(Char -> Symbol
sym Char
c, [Symbol
"o", Char -> Symbol
sym (Char -> Char
Char.toLower Char
c)]) | Char
c <- [Char]
"KTNDUVI"]
    sym :: Char -> Symbol
sym = Text -> Symbol
Expr.Symbol forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
Text.singleton

-- | Strokes which have a pitch, which should change with the sruti.
pitched_strokes :: [Attrs.Attributes]
pitched_strokes :: [Attributes]
pitched_strokes =
    [ Attributes
nam, Attributes
din
    , Attributes
kin, Attributes
tan
    , Attributes
chapu
    , Attributes
dheem
    ]

all_strokes :: [Drums.Stroke]
all_strokes :: [Stroke]
all_strokes = [Stroke]
left_notes forall a. [a] -> [a] -> [a]
++ [Stroke]
right_notes

-- | The convention is symbols for thoppi, and letters for valantalai.  Also,
-- vowels for open sounds, consonants for closed ones.  Soft strokes look like
-- a simpler version of their equivalent loud strokes.
left_notes, right_notes :: [Drums.Stroke]
stops :: Drums.Stops
([Stroke]
left_notes, [Stroke]
right_notes, Stops
stops) = ([Stroke]
left_notes, [Stroke]
right_notes, Stops
stops)
    where
    left_notes :: [Stroke]
left_notes = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ Text -> [Stroke] -> [Stroke]
group Text
t_closed
            [ Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'a' Symbol
"-" Attributes
tha Y
0.5
            , Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'z' Symbol
"+" Attributes
tha Y
0.75
            , Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'Z' Symbol
"*" Attributes
tha Y
1
            , Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'A' Symbol
"*_" (Attributes
tha forall a. Semigroup a => a -> a -> a
<> Attributes
fingers) Y
1
            -- This often alternates with o_.
            , Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'C' Symbol
"+_" (Attributes
tha forall a. Semigroup a => a -> a -> a
<> Attributes
fingertips) Y
1
            ]
        , Text -> [Stroke] -> [Stroke]
group Text
t_open
            [ Char -> Symbol -> Attributes -> Y -> Stroke
n Char
's' Symbol
"." Attributes
thom Y
0.5
            , Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'x' Symbol
"o" Attributes
thom Y
1
            , Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'd' Symbol
"._" Attributes
gumki Y
0.5
            , Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'c' Symbol
"o_" Attributes
gumki Y
1
            , Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'f' Symbol
"o-" (Attributes
gumki forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.medium) Y
1
            , Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'g' Symbol
"o^" (Attributes
gumki forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.high) Y
1
            , Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'v' Symbol
"o/" (Attributes
gumki forall a. Semigroup a => a -> a -> a
<> Attributes
Attrs.up) Y
1
            -- TODO when I have samples, have 'o 0' to 'o 1' for arbitrary
            -- pitches.
            ]
        ]
    right_notes :: [Stroke]
right_notes = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ Text -> [Stroke] -> [Stroke]
group Text
v_closed
            -- TODO this should be mi, played with middle finger, but I have no
            -- sample for it
            [ Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'1' Symbol
"l" Attributes
ki Y
0.5
            , Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'q' Symbol
"k" Attributes
ki Y
1
            , Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'w' Symbol
"t" Attributes
ta Y
1
            ]
        , Text -> [Stroke] -> [Stroke]
group Text
v_sadam
            [ Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'2' Symbol
"'" Attributes
min Y
1
            , Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'3' Symbol
"^" Attributes
tan Y
1
            , Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'e' Symbol
"n" Attributes
nam Y
1
            , Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'4' Symbol
"," Attributes
kin Y
1
            , Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'r' Symbol
"d" Attributes
din Y
1
            ]
        , Text -> [Stroke] -> [Stroke]
group Text
v_chapu
            [ Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'5' Symbol
"v" (Attributes
muru forall a. Semigroup a => a -> a -> a
<> Attributes
chapu) Y
1
            , Char -> Symbol -> Attributes -> Y -> Stroke
n Char
't' Symbol
"u" (Attributes
arai forall a. Semigroup a => a -> a -> a
<> Attributes
chapu) Y
1
            ]
        , Text -> [Stroke] -> [Stroke]
group Text
v_dheem [Char -> Symbol -> Attributes -> Y -> Stroke
n Char
'y' Symbol
"i" Attributes
dheem Y
1]
        ]

    -- each group with the groups it stops
    stops :: Stops
stops =
        [ (Text
t_closed, [Text
t_open])
        , (Text
v_closed, [Text
v_sadam, Text
v_chapu, Text
v_dheem])
        , (Text
v_sadam, [Text
v_chapu, Text
v_dheem])
        , (Text
v_chapu, [Text
v_dheem])
        ]
    v_closed :: Text
v_closed = Text
"v-closed"
    v_sadam :: Text
v_sadam = Text
"v-sadam"
    v_chapu :: Text
v_chapu = Text
"v-chapu"
    v_dheem :: Text
v_dheem = Text
"v-dheem"
    t_closed :: Text
t_closed = Text
"t-closed"
    t_open :: Text
t_open = Text
"t-open"
    group :: Text -> [Stroke] -> [Stroke]
group Text
name = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ \Stroke
n -> Stroke
n { _group :: Text
Drums._group = Text
name }
    n :: Char -> Symbol -> Attributes -> Y -> Stroke
n = Char -> Symbol -> Attributes -> Y -> Stroke
Drums.stroke_dyn

tha :: Attributes
tha = Text -> Attributes
Attrs.attr Text
"tha"
thom :: Attributes
thom = Text -> Attributes
Attrs.attr Text
"thom"
ki :: Attributes
ki = Text -> Attributes
Attrs.attr Text
"ki"
ta :: Attributes
ta = Text -> Attributes
Attrs.attr Text
"ta"
min :: Attributes
min = Text -> Attributes
Attrs.attr Text
"min" -- like ta or mi, but on meetu so din rings
nam :: Attributes
nam = Text -> Attributes
Attrs.attr Text
"nam"
din :: Attributes
din = Text -> Attributes
Attrs.attr Text
"din"
dheem :: Attributes
dheem = Text -> Attributes
Attrs.attr Text
"dheem"
chapu :: Attributes
chapu = Text -> Attributes
Attrs.attr Text
"chapu"
muru :: Attributes
muru = Text -> Attributes
Attrs.attr Text
"muru"
arai :: Attributes
arai = Text -> Attributes
Attrs.attr Text
"arai"
kin :: Attributes
kin = Text -> Attributes
Attrs.attr Text
"kin"
tan :: Attributes
tan = Text -> Attributes
Attrs.attr Text
"tan"

gumki :: Attributes
gumki = Text -> Attributes
Attrs.attr Text
"gumki"

-- tha variations
fingers :: Attributes
fingers = Text -> Attributes
Attrs.attr Text
"fingers" -- played with flat fingers, not palm
fingertips :: Attributes
fingertips = Text -> Attributes
Attrs.attr Text
"fingertips"
-- TODO roll is roll with fingertips?


-- * two-handed pitched drums

-- | Make code for a pitched two-handed drum.  This isn't mridangam-specific.
make_code :: CUtil.Thru -> [Attrs.Attributes] -> Pitch.NoteNumber
    -> Maybe (Derive.TransformerF Derive.Note) -> [Drums.Stroke]
    -> [(Expr.Symbol, [Expr.Symbol], Maybe Char)] -> ImInst.Code
make_code :: Thru
-> [Attributes]
-> NoteNumber
-> Maybe (TransformerF Note)
-> [Stroke]
-> [(Symbol, [Symbol], Maybe Char)]
-> Code
make_code Thru
thru [Attributes]
pitched_strokes NoteNumber
natural_nn Maybe (TransformerF Note)
transform [Stroke]
strokes [(Symbol, [Symbol], Maybe Char)]
both = forall a. Monoid a => [a] -> a
mconcat
    [ [(Symbol, Generator Note)] -> Code
ImInst.note_generators [(Symbol, Generator Note)]
generators
    , [(Symbol, ValCall)] -> Code
ImInst.val_calls [(Symbol, ValCall)]
vals
    , HandlerId -> Code
ImInst.cmd (forall (m :: * -> *). M m => Thru -> [(Char, Symbol)] -> Handler m
CUtil.insert_call Thru
thru [(Char, Symbol)]
char_to_call)
    ]
    where
    add :: TransformerF a -> [p a (Generator a)] -> [p a (Generator a)]
add TransformerF a
t = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. Doc -> TransformerF a -> Generator a -> Generator a
Make.modify_generator_ Doc
"" TransformerF a
t))
    generators :: [(Symbol, Generator Note)]
generators = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall {p :: * -> * -> *} {a} {a}.
Bifunctor p =>
TransformerF a -> [p a (Generator a)] -> [p a (Generator a)]
add Maybe (TransformerF Note)
transform forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [(Stroke, CallConfig)] -> [(Symbol, Generator Note)]
CUtil.drum_calls (forall a b. [a] -> [b] -> [(a, b)]
zip [Stroke]
strokes (forall a b. (a -> b) -> [a] -> [b]
map Stroke -> CallConfig
config [Stroke]
strokes))
        , [(Symbol, [Symbol])] -> [(Symbol, Generator Note)]
DUtil.multiple_calls [(Symbol
call, [Symbol]
subcalls) | (Symbol
call, [Symbol]
subcalls, Maybe Char
_) <- [(Symbol, [Symbol], Maybe Char)]
both]
        ]
    config :: Stroke -> CallConfig
config = [Attributes] -> NoteNumber -> Attributes -> CallConfig
CUtil.pitched_strokes [Attributes]
pitched_strokes NoteNumber
natural_nn
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stroke -> Attributes
Drums._attributes
    vals :: [(Symbol, ValCall)]
vals =
        [ (Symbol
"natural", forall a.
(ToVal a, ShowVal a) =>
Module -> CallName -> Doc -> a -> ValCall
Make.constant_val Module
Module.instrument CallName
"natural"
            Doc
doc (NoteNumber -> Pitch
PSignal.nn_pitch NoteNumber
natural_nn))
        ]
        where doc :: Doc
doc = Doc
"Emit the drum's recorded pitch. Use like `#=(natural)`."
    char_to_call :: [(Char, Symbol)]
char_to_call = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [(Stroke -> Char
Drums._char Stroke
n, Stroke -> Symbol
Drums._name Stroke
n) | Stroke
n <- [Stroke]
strokes]
        , [(Char
char, Symbol
call) | (Symbol
call, [Symbol]
_, Just Char
char) <- [(Symbol, [Symbol], Maybe Char)]
both]
        ]

-- | Create calls for all simultaneous left and right hand combinations, and
-- key bindings for a few common ones.
make_both :: [Drums.Stroke] -> [Drums.Stroke]
    -> [(Expr.Symbol, [Expr.Symbol])] -- ^ special names for pairs
    -> [(Expr.Symbol, Char)] -> [(Expr.Symbol, [Expr.Symbol], Maybe Char)]
make_both :: [Stroke]
-> [Stroke]
-> [(Symbol, [Symbol])]
-> [(Symbol, Char)]
-> [(Symbol, [Symbol], Maybe Char)]
make_both [Stroke]
left [Stroke]
right [(Symbol, [Symbol])]
special_names [(Symbol, Char)]
keys =
    [ (Symbol
call, [Symbol]
subcalls, forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Symbol
call [(Symbol, Char)]
keys)
    | (Symbol
call, [Symbol]
subcalls) <- [(Symbol, [Symbol])]
special_names forall a. [a] -> [a] -> [a]
++ [(Symbol, [Symbol])]
pairs
    ]
    where
    pairs :: [(Symbol, [Symbol])]
pairs =
        [ (Text -> Symbol
Expr.Symbol forall a b. (a -> b) -> a -> b
$ Symbol -> Text
u Symbol
lcall forall a. Semigroup a => a -> a -> a
<> Symbol -> Text
u Symbol
rcall, [Symbol
lcall, Symbol
rcall])
        | Symbol
lcall <- forall a b. (a -> b) -> [a] -> [b]
map Stroke -> Symbol
Drums._name [Stroke]
left
        , Symbol
rcall <- forall a b. (a -> b) -> [a] -> [b]
map Stroke -> Symbol
Drums._name [Stroke]
right
        , Text -> Int
Text.length (Symbol -> Text
u Symbol
lcall) forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Text -> Int
Text.length (Symbol -> Text
u Symbol
rcall) forall a. Eq a => a -> a -> Bool
== Int
1
        ]
    u :: Symbol -> Text
u = Symbol -> Text
Expr.unsym