-- 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.Maps as Maps
import qualified Util.Seq as Seq
import qualified Util.Texts as Texts

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


write :: FilePath -> Either Text Text -> IO ()
write :: String -> Either Text Text -> IO ()
write String
fname = (Text -> IO ()) -> (Text -> IO ()) -> Either Text Text -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> IO ()
forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO ((Text -> IO ()) -> Either Text Text -> IO ())
-> (Text -> IO ()) -> Either Text Text -> IO ()
forall a b. (a -> b) -> a -> b
$ \Text
t -> do
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"write " String -> String -> String
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 = [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (Text
"TITLE", Text -> Text
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 = (Maybe NoteNumber -> Int) -> [Maybe NoteNumber] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> (NoteNumber -> Int) -> Maybe NoteNumber -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (-Int
1) (NoteNumber -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (NoteNumber -> Int)
-> (NoteNumber -> NoteNumber) -> NoteNumber -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NoteNumber -> NoteNumber -> NoteNumber
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 NoteNumber -> NoteNumber -> NoteNumber
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 = [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            [ (Text
"INSTRUMENT", Text
instrument)
            , (Text
"MAX_GROUPS", Int -> Text
forall a. Show a => a -> Text
showt ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
groups))
            , (Text
"MAX_KEYSWITCHES", Int -> Text
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, [[(Text, (Key, Key))]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[(Text, (Key, Key))]]
keyswitch_strokes)
    where
    pitch_to_group :: [Int]
pitch_to_group = Vector Int -> [Int]
forall a. Unbox a => Vector a -> [a]
Vector.toList (Vector Int -> [Int]) -> Vector Int -> [Int]
forall a b. (a -> b) -> a -> b
$ [Vector Int] -> Vector Int
forall a. Monoid a => [a] -> a
mconcat ([Vector Int] -> Vector Int) -> [Vector Int] -> Vector Int
forall a b. (a -> b) -> a -> b
$ ([(Text, (Key, Key))] -> Vector Int)
-> [[(Text, (Key, Key))]] -> [Vector Int]
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 = Int -> [((Int, Int), Int)] -> Vector Int
forall a. Unbox a => a -> [((Int, Int), a)] -> Vector a
midi_pitch_array Int
none
        [ ((Key -> Int
forall a. Num a => Key -> a
Midi.from_key Key
s, Key -> Int
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 = Vector Int -> [Int]
forall a. Unbox a => Vector a -> [a]
Vector.toList (Vector Int -> [Int]) -> Vector Int -> [Int]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Vector Int
forall a. Unbox a => Int -> a -> Vector a
Vector.replicate Int
128 Int
none
        Vector Int -> [(Int, Int)] -> Vector Int
forall a. Unbox a => Vector a -> [(Int, a)] -> Vector a
Vector.// [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Key -> Int) -> [Key] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Key -> Int
forall a. Num a => Key -> a
Midi.from_key [Key]
keyswitches) [Int
0..]
    ([Key]
keyswitches, [[(Text, (Key, Key))]]
keyswitch_strokes) =
        [(Key, [(Text, (Key, Key))])] -> ([Key], [[(Text, (Key, Key))]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Key, [(Text, (Key, Key))])] -> ([Key], [[(Text, (Key, Key))]]))
-> [(Key, [(Text, (Key, Key))])] -> ([Key], [[(Text, (Key, Key))]])
forall a b. (a -> b) -> a -> b
$ Map Key [(Text, (Key, Key))] -> [(Key, [(Text, (Key, Key))])]
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 = [(Key, (Text, (Key, Key)))] -> Map Key [(Text, (Key, Key))]
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 = (Text -> Text) -> [Text] -> [Text]
forall k a. Eq k => (a -> k) -> [a] -> [a]
Seq.drop_dups Text -> Text
forall a. a -> a
id ([Text] -> [Text]
forall a. Ord a => [a] -> [a]
List.sort (((Stroke, KeyswitchRange) -> Text) -> PitchedStrokes -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Stroke -> Text
Drums._group (Stroke -> Text)
-> ((Stroke, KeyswitchRange) -> Stroke)
-> (Stroke, KeyswitchRange)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stroke, KeyswitchRange) -> Stroke
forall a b. (a, b) -> a
fst) PitchedStrokes
strokes))
    group_to_id :: Map Text Int
group_to_id = [(Text, Int)] -> Map Text Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Int)] -> Map Text Int) -> [(Text, Int)] -> Map Text Int
forall a b. (a -> b) -> a -> b
$ [Text] -> [Int] -> [(Text, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
groups [Int
0..]
    group_id :: Text -> Int
group_id Text
g = Int -> Text -> Map Text Int -> Int
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
    ((Text, [Text]) -> Either Text Int)
-> [(Text, [Text])] -> Either Text ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> Either Text Int
get (Text -> Either Text Int)
-> ((Text, [Text]) -> Text) -> (Text, [Text]) -> Either Text Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, [Text]) -> Text
forall a b. (a, b) -> a
fst) [(Text, [Text])]
stop_groups -- ensure all groups in stop_groups are known
    (Text -> Either Text [Int]) -> [Text] -> Either Text [Int]
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 = [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
groups
    realize :: Text -> Either Text [Int]
realize Text
group = do
        [Int]
stops <- (Text -> Either Text Int) -> [Text] -> Either Text [Int]
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
        [Int] -> Either Text [Int]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> Either Text [Int]) -> [Int] -> Either Text [Int]
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
ngroups ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int]
stops [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ Int -> [Int]
forall a. a -> [a]
repeat Int
none
        where stops :: [Text]
stops = [Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [Text] -> [Text]) -> Maybe [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, [Text])] -> Maybe [Text]
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 = Text -> Maybe Int -> Either Text Int
forall err a. err -> Maybe a -> Either err a
justErr (Text
"no group: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
showt Text
g) (Maybe Int -> Either Text Int) -> Maybe Int -> Either Text Int
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Maybe Int
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 =
    Int -> a -> Vector a
forall a. Unbox a => Int -> a -> Vector a
Vector.replicate Int
128 a
deflt Vector a -> [(Int, a)] -> Vector a
forall a. Unbox a => Vector a -> [(Int, a)] -> Vector a
Vector.// (((Int, Int), a) -> [(Int, a)]) -> [((Int, Int), a)] -> [(Int, a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Int, Int), a) -> [(Int, a)]
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 <- a -> a -> a -> [a]
forall a. (Num a, Ord a) => a -> a -> a -> [a]
Seq.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 =
    Bool
-> Char -> (Text -> Either Text Text) -> Text -> Either Text Text
forall (m :: * -> *).
Monad m =>
Bool -> Char -> (Text -> m Text) -> Text -> m Text
Texts.mapDelimitedM Bool
False Char
'*' ((Text -> Either Text Text) -> Text -> Either Text Text)
-> (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ \Text
v ->
        Text -> Maybe Text -> Either Text Text
forall err a. err -> Maybe a -> Either err a
justErr (Text
"no value for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
showt Text
v) (Maybe Text -> Either Text Text) -> Maybe Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Text -> Maybe Text
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"<>) (Text -> Text) -> ([Int] -> Text) -> [Int] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
")") (Text -> Text) -> ([Int] -> Text) -> [Int] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate Text
", ...\n" ([Text] -> Text) -> ([Int] -> [Text]) -> [Int] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> Text) -> [[Text]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
indent<>)
        (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate Text
", ") ([[Text]] -> [Text]) -> ([Int] -> [[Text]]) -> [Int] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Text] -> [[Text]]
forall a. Int -> [a] -> [[a]]
Seq.chunked Int
chunk_size ([Text] -> [[Text]]) -> ([Int] -> [Text]) -> [Int] -> [[Text]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Text
forall a. Show a => a -> Text
showt
    where indent :: Text
indent = Int -> Text -> Text
Text.replicate Int
8 Text
" "