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

-- | Utilities for kontakt.
module User.Elaforge.Instrument.Kontakt.Util where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified Data.Vector.Unboxed as Vector

import qualified Util.Lists as Lists
import qualified Util.Maps as Maps
import qualified Util.Texts as Texts

import qualified Cmd.Instrument.CUtil as CUtil
import qualified Cmd.Instrument.Drums as Drums
import qualified Midi.Midi as Midi
import qualified Perform.Midi.Patch as Patch

import           Global


write :: FilePath -> Either Text Text -> IO ()
write :: String -> Either Text Text -> IO ()
write String
fname = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO forall a b. (a -> b) -> a -> b
$ \Text
t -> do
    String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"write " forall a. Semigroup a => a -> a -> a
<> String
fname
    String -> Text -> IO ()
Text.IO.writeFile String
fname Text
t

-- * tuning_ksp

-- | Create a script in Kontakt's hilariously incompetent KSP language to
-- retune a 12TET patch to the given scale.
tuning_ksp :: Maybe Patch.AttributeMap -> Patch.Scale -> Either Text Text
tuning_ksp :: Maybe AttributeMap -> Scale -> Either Text Text
tuning_ksp Maybe AttributeMap
attr_map Scale
scale = Map Text Text -> Text -> Either Text Text
interpolate Map Text Text
values Text
tuning_template
    where
    values :: Map Text Text
values = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (Text
"TITLE", forall a. Show a => a -> Text
showt (Scale -> Text
Patch.scale_name Scale
scale))
        , (Text
"PITCHES", Int -> [Int] -> Text
ksp_array Int
6 [Int]
pitches)
        ]
    -- -1 marks unmapped pitches, since it's visually distinct from 0.
    pitches :: [Int]
pitches = forall a b. (a -> b) -> [a] -> [b]
map (forall b a. b -> (a -> b) -> Maybe a -> b
maybe (-Int
1) (forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
*NoteNumber
millicent)))
        (Maybe AttributeMap -> Scale -> [Maybe NoteNumber]
Patch.scale_offsets Maybe AttributeMap
attr_map Scale
scale)
    millicent :: NoteNumber
millicent = NoteNumber
1000 forall a. Num a => a -> a -> a
* NoteNumber
100 -- silly scent willy sent

tuning_template :: Text
tuning_template :: Text
tuning_template =
    -- To ignore notes that don't have a tuning, I could set another %set array
    -- with 0 or 1, and do ignore_event($EVENT_ID).
    Text
"on init\n\
    \    set_script_title(*TITLE*)\n\
    \    declare %Pitches[128] := *PITCHES*\n\
    \end on\n\
    \\n\
    \on note\n\
    \    change_tune($EVENT_ID, %Pitches[$EVENT_NOTE], 0)\n\
    \end on\n"

-- * drum_mute_ksp

-- | Create KSP to handle sample stopping.  Each drum Note has a Group, and
-- each Group can stop a set of other groups from sounding.
--
-- Kontakt has a built-in mechanism, but as usual it gets it wrong.  The
-- built-in mechanism lets you assign notes to a group, and limit voices in the
-- group, which means that two of the same strokes in a row will mute each
-- other.
drum_mute_ksp :: Text -> CUtil.PitchedStrokes -> [(Drums.Group, [Drums.Group])]
    -- ^ each Group along with a set of Groups that it stops
    -> Either Text Text
drum_mute_ksp :: Text -> PitchedStrokes -> [(Text, [Text])] -> Either Text Text
drum_mute_ksp Text
instrument PitchedStrokes
strokes [(Text, [Text])]
stop_groups = do
    [Int]
stop_group_ids <- [(Text, [Text])] -> [Text] -> Either Text [Int]
make_stop_groups [(Text, [Text])]
stop_groups [Text]
groups
    let values :: Map Text Text
values = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            [ (Text
"INSTRUMENT", Text
instrument)
            , (Text
"MAX_GROUPS", forall a. Show a => a -> Text
showt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
groups))
            , (Text
"MAX_KEYSWITCHES", forall a. Show a => a -> Text
showt Int
max_keyswitches)
            , (Text
"PITCH_TO_GROUP", Int -> [Int] -> Text
ksp_array Int
8 [Int]
pitch_to_group)
            , (Text
"PITCH_TO_KEYSWITCH", Int -> [Int] -> Text
ksp_array Int
8 [Int]
pitch_to_keyswitch)
            , (Text
"STOP_GROUPS", Int -> [Int] -> Text
ksp_array Int
8 [Int]
stop_group_ids)
            ]
    Map Text Text -> Text -> Either Text Text
interpolate Map Text Text
values Text
drum_mute_template
    where
    ([Int]
pitch_to_keyswitch, [Int]
pitch_to_group, [Text]
groups, Int
max_keyswitches) =
        PitchedStrokes -> ([Int], [Int], [Text], Int)
drum_mute_values PitchedStrokes
strokes

drum_mute_values :: CUtil.PitchedStrokes -> ([Int], [Int], [Drums.Group], Int)
drum_mute_values :: PitchedStrokes -> ([Int], [Int], [Text], Int)
drum_mute_values PitchedStrokes
strokes =
    ([Int]
pitch_to_keyswitch, [Int]
pitch_to_group, [Text]
groups, forall (t :: * -> *) a. Foldable t => t a -> Int
length [[(Text, (Key, Key))]]
keyswitch_strokes)
    where
    pitch_to_group :: [Int]
pitch_to_group = forall a. Unbox a => Vector a -> [a]
Vector.toList forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map [(Text, (Key, Key))] -> Vector Int
make [[(Text, (Key, Key))]]
keyswitch_strokes
    make :: [(Text, (Key, Key))] -> Vector Int
make [(Text, (Key, Key))]
ks_strokes = forall a. Unbox a => a -> [((Int, Int), a)] -> Vector a
midi_pitch_array Int
none
        [ ((forall a. Num a => Key -> a
Midi.from_key Key
s, forall a. Num a => Key -> a
Midi.from_key Key
e), Text -> Int
group_id Text
group)
        | (Text
group, (Key
s, Key
e)) <- [(Text, (Key, Key))]
ks_strokes
        ]
    pitch_to_keyswitch :: [Int]
pitch_to_keyswitch = forall a. Unbox a => Vector a -> [a]
Vector.toList forall a b. (a -> b) -> a -> b
$ forall a. Unbox a => Int -> a -> Vector a
Vector.replicate Int
128 Int
none
        forall a. Unbox a => Vector a -> [(Int, a)] -> Vector a
Vector.// forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => Key -> a
Midi.from_key [Key]
keyswitches) [Int
0..]
    ([Key]
keyswitches, [[(Text, (Key, Key))]]
keyswitch_strokes) =
        forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toAscList Map Key [(Text, (Key, Key))]
keyswitch_to_strokes
    -- If this instrument doesn't use keyswitches (it could use
    -- 'Patch.ControlSwitch'es), then they all wind up with 0.  I need
    -- at least one keyswitch so pitch_to_group isn't empty, and pretending
    -- there's one at 0 is fine since it never changes.  This is fine, assuming
    -- that overlapping groups all belong to the same stop gorup.
    keyswitch_to_strokes :: Map Key [(Text, (Key, Key))]
keyswitch_to_strokes = forall k a. Ord k => [(k, a)] -> Map k [a]
Maps.multimap
        [ ([Keyswitch] -> Key
ks_of [Keyswitch]
keyswitch, (Stroke -> Text
Drums._group Stroke
stroke, (Key
low, Key
high)))
        | (Stroke
stroke, ([Keyswitch]
keyswitch, Key
low, Key
high, Key
_)) <- PitchedStrokes
strokes
        ]
    ks_of :: [Keyswitch] -> Key
ks_of (Patch.Keyswitch Key
ks : [Keyswitch]
_) = Key
ks
    ks_of [Keyswitch]
_ = Key
0
    groups :: [Text]
groups = forall k a. Eq k => (a -> k) -> [a] -> [a]
Lists.dropDups forall a. a -> a
id (forall a. Ord a => [a] -> [a]
List.sort (forall a b. (a -> b) -> [a] -> [b]
map (Stroke -> Text
Drums._group forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) PitchedStrokes
strokes))
    group_to_id :: Map Text Int
group_to_id = 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 [Text]
groups [Int
0..]
    group_id :: Text -> Int
group_id Text
g = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Int
none Text
g Map Text Int
group_to_id

-- | Used in KSP for a nothing value.
none :: Int
none :: Int
none = -Int
1

make_stop_groups :: [(Drums.Group, [Drums.Group])] -> [Drums.Group]
    -> Either Text [Int]
make_stop_groups :: [(Text, [Text])] -> [Text] -> Either Text [Int]
make_stop_groups [(Text, [Text])]
stop_groups [Text]
groups = do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> Either Text Int
get forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Text, [Text])]
stop_groups -- ensure all groups in stop_groups are known
    forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM Text -> Either Text [Int]
realize [Text]
groups
    where
    ngroups :: Int
ngroups = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
groups
    realize :: Text -> Either Text [Int]
realize Text
group = do
        [Int]
stops <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> Either Text Int
get [Text]
stops
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
ngroups forall a b. (a -> b) -> a -> b
$ [Int]
stops forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat Int
none
        where stops :: [Text]
stops = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
group [(Text, [Text])]
stop_groups
    get :: Text -> Either Text Int
get Text
g = forall err a. err -> Maybe a -> Either err a
justErr (Text
"no group: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
g) forall a b. (a -> b) -> a -> b
$ forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex Text
g [Text]
groups

midi_pitch_array :: Vector.Unbox a => a -> [((Int, Int), a)] -> Vector.Vector a
midi_pitch_array :: forall a. Unbox a => a -> [((Int, Int), a)] -> Vector a
midi_pitch_array a
deflt [((Int, Int), a)]
ranges =
    forall a. Unbox a => Int -> a -> Vector a
Vector.replicate Int
128 a
deflt forall a. Unbox a => Vector a -> [(Int, a)] -> Vector a
Vector.// forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a} {b}. (Num a, Ord a) => ((a, a), b) -> [(a, b)]
expand [((Int, Int), a)]
ranges
    where expand :: ((a, a), b) -> [(a, b)]
expand ((a
s, a
e), b
v) = [(a
i, b
v) | a
i <- forall a. (Num a, Ord a) => a -> a -> a -> [a]
Lists.range' a
s a
e a
1]

drum_mute_template :: Text
drum_mute_template :: Text
drum_mute_template =
    Text
"on init\n\
    \    set_script_title(\"drum-mute for *INSTRUMENT*\")\n\
    \\n\
    \    {- immutable, CamelCase -}\n\
    \    declare const $None := -1\n\
    \    declare const $FadeTimeUs := 100 * 1000\n\
    \    {- map pitch note number to group, or $None to apply no processing -}\n\
    \    declare const $MaxGroups := *MAX_GROUPS*\n\
    \    declare const $MaxKeyswitches := *MAX_KEYSWITCHES*\n\
    \    {- remember this many sounding notes -}\n\
    \    declare const $MaxVoices := 4\n\
    \    declare %PitchToGroup[128 * $MaxKeyswitches] := *PITCH_TO_GROUP*\n\
    \    {- keyswitch numbers for keyswitch notes, -1 for the rest -}\n\
    \    declare %PitchToKeyswitch[128] := *PITCH_TO_KEYSWITCH*\n\
    \    {- map a group to the other groups it should stop -}\n\
    \    declare %StopGroups[$MaxGroups * $MaxGroups] := *STOP_GROUPS*\n\
    \\n\
    \    {- mutable, lower_under -}\n\
    \    {- map a group to sounding events in that event -}\n\
    \    declare %sounding_groups[$MaxGroups * $MaxVoices]\n\
    \    {- current active keyswitch -}\n\
    \    declare $keyswitch\n\
    \\n\
    \    {- scratch -}\n\
    \    declare $addr\n\
    \    declare $event\n\
    \    declare $group\n\
    \    declare $i\n\
    \    declare $j\n\
    \    declare $stop_group\n\
    \    declare $to\n\
    \\n\
    \    $i := 0\n\
    \    while ($i < num_elements(%sounding_groups))\n\
    \        %sounding_groups[$i] := $None\n\
    \        $i := $i + 1\n\
    \    end while\n\
    \\n\
    \    $keyswitch := 0\n\
    \end on\n\
    \\n\
    \on note\n\
    \    if (%PitchToKeyswitch[$EVENT_NOTE] # $None)\n\
    \        $keyswitch := %PitchToKeyswitch[$EVENT_NOTE]\n\
    \    end if\n\
    \\n\
    \    $group := %PitchToGroup[$EVENT_NOTE + $keyswitch * 128]\n\
    \    if ($group = $None)\n\
    \        exit\n\
    \    end if\n\
    \\n\
    \    $addr := $group * $MaxVoices\n\
    \    {- turn off all sounding notes stopped by this group -}\n\
    \    $i := 0\n\
    \    while ($i < $MaxGroups)\n\
    \        $stop_group := %StopGroups[$group * $MaxGroups + $i]\n\
    \        if ($stop_group # $None)\n\
    \            $j := 0\n\
    \            while ($j < $MaxVoices)\n\
    \                $event := %sounding_groups[$stop_group * $MaxVoices + $j]\n\
    \                if ($event # $None)\n\
    \                    fade_out($event, $FadeTimeUs, 1)\n\
    \                    %sounding_groups[$stop_group * $MaxVoices + $j] := $None\n\
    \                end if\n\
    \                $j := $j + 1\n\
    \            end while\n\
    \        end if\n\
    \        $i := $i + 1\n\
    \    end while\n\
    \\n\
    \    {- put this note into %sounding_groups -}\n\
    \    {- if I've run out of voices, turn off the last note -}\n\
    \    if (%sounding_groups[$addr + $MaxVoices - 1] # $None)\n\
    \        fade_out(%sounding_groups[$addr + $MaxVoices - 1], $FadeTimeUs, 1)\n\
    \    end if\n\
    \\n\
    \    {- move notes up, and insert a new one at 0 -}\n\
    \    $i := $MaxVoices - 1\n\
    \    while ($i > 0)\n\
    \        %sounding_groups[$addr + $i] := %sounding_groups[$addr + $i - 1]\n\
    \        $i := $i - 1\n\
    \    end while\n\
    \    %sounding_groups[$addr] := $EVENT_ID\n\
    \end on\n"


-- * util

interpolate :: Map Text Text -> Text -> Either Text Text
interpolate :: Map Text Text -> Text -> Either Text Text
interpolate Map Text Text
values =
    forall (m :: * -> *).
Monad m =>
Bool -> Char -> (Text -> m Text) -> Text -> m Text
Texts.mapDelimitedM Bool
False Char
'*' forall a b. (a -> b) -> a -> b
$ \Text
v ->
        forall err a. err -> Maybe a -> Either err a
justErr (Text
"no value for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Text
v) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
v Map Text Text
values

ksp_array :: Int -> [Int] -> Text
ksp_array :: Int -> [Int] -> Text
ksp_array Int
chunk_size =
    (Text
"( ...\n"<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<>Text
")") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate Text
", ...\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((Text
indent<>)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate Text
", ") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [[a]]
Lists.chunked Int
chunk_size forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> Text
showt
    where indent :: Text
indent = Int -> Text -> Text
Text.replicate Int
8 Text
" "