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

{- | Functions to deal with tuning instruments.

    E.g.:

    > LTuning.realtime "pno" =<< LTuning.selection True
    > LTuning.write_ksp (Just "wayang") "charu.ksp"
    >       =<< LTuning.scale True "raga" "key=charukesi"

    nrpn tuning is a lot less hassle than copy pasting KSP everywhere:

    > LTuning.nrpn "pemade" =<< LTuning.selection True

    Don't forget to set the score to the same scale or things will sound
    confusing.  Also, reaper won't receive sysex on a track unless you set it
    to receive all channels.

    To retune all instruments that do tuning via either 'nrpn' or 'realtime':

    > LTuning.retune =<< LTuning.selection True
-}
module Cmd.Repl.LTuning where
import qualified Data.Maybe as Maybe
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import qualified Data.Vector.Unboxed as Unboxed

import qualified Util.Num as Num
import qualified Util.Lists as Lists
import qualified Util.Texts as Texts

import qualified Cmd.Cmd as Cmd
import qualified Cmd.InputNote as InputNote
import qualified Cmd.Perf as Perf
import qualified Cmd.PlayUtil as PlayUtil
import qualified Cmd.Repl.LInst as LInst
import qualified Cmd.Repl.Util as Util
import qualified Cmd.Selection as Selection

import qualified Derive.C.Prelude.Equal as Equal
import qualified Derive.Call as Call
import qualified Derive.Derive as Derive
import qualified Derive.Scale as Scale
import qualified Derive.Scale.BaliScales as BaliScales
import qualified Derive.Scale.Legong as Legong
import qualified Derive.Scale.Wayang as Wayang

import qualified Instrument.Common as Common
import qualified Midi.Midi as Midi
import qualified Perform.Midi.Patch as Patch
import qualified Perform.Pitch as Pitch
import qualified User.Elaforge.Instrument.Kontakt.Util as Kontakt.Util

import           Global
import           Types


-- * Patch.Scale

-- | Format a Patch.Scale as a table.
table :: Patch.Scale -> Text
table :: Scale -> Text
table Scale
scale =
    [Text] -> Text
Text.unlines forall a b. (a -> b) -> a -> b
$ Int -> [[Text]] -> [Text]
Texts.columns Int
1 forall a b. (a -> b) -> a -> b
$
        [Text
"", Text
"c", Text
"", Text
"d", Text
"", Text
"e", Text
"f", Text
"", Text
"g", Text
"", Text
"a", Text
"", Text
"b"]
        forall a. a -> [a] -> [a]
: [Text
oct forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a. RealFloat a => Int -> a -> Text
Num.showFloat Int
2) [Double]
nns | (Text
oct, [Double]
nns) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
octaves [[Double]]
groups]
    where
    octaves :: [Text]
octaves = forall a b. (a -> b) -> [a] -> [b]
map ((Text
"c"<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Text
showt) [-Integer
1..]
    groups :: [[Double]]
groups = forall a. Int -> [a] -> [[a]]
Lists.chunked Int
12 forall a b. (a -> b) -> a -> b
$ forall a. Unbox a => Vector a -> [a]
Unboxed.toList forall a b. (a -> b) -> a -> b
$ Scale -> Vector Double
Patch.scale_key_to_nn Scale
scale

-- | Get a patch scale for the scale at the selection.
selection :: Cmd.M m => Bool
    -- ^ False to throw if there are warnings or errors, True to ignore them.
    -> m Patch.Scale
selection :: forall (m :: * -> *). M m => Bool -> m Scale
selection Bool
ignore_errors = do
    (BlockId
block_id, Int
_, TrackId
track_id, TrackTime
_) <- forall (m :: * -> *). M m => m (BlockId, Int, TrackId, TrackTime)
Selection.get_insert
    (Scale
scale, [Text]
errs) <- forall (m :: * -> *).
M m =>
BlockId -> TrackId -> m (Scale, [Text])
scale_at BlockId
block_id TrackId
track_id
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
ignore_errors Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
errs) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines [Text]
errs
    forall (m :: * -> *) a. Monad m => a -> m a
return Scale
scale

-- | Figure out a 'Patch.Scale' by enumerating all inputs to the scale in
-- scope.
scale_at :: Cmd.M m => BlockId -> TrackId -> m (Patch.Scale, [Text])
scale_at :: forall (m :: * -> *).
M m =>
BlockId -> TrackId -> m (Scale, [Text])
scale_at BlockId
block_id TrackId
track_id = do
    Scale
scale <- forall (m :: * -> *) a.
M m =>
BlockId -> TrackId -> Deriver a -> m a
Perf.derive_at_throw BlockId
block_id TrackId
track_id Deriver Scale
Call.get_scale
    ([Maybe (Key, NoteNumber)]
key_nns, [[Text]]
errs) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Key, Input)]
all_inputs forall a b. (a -> b) -> a -> b
$ \(Key
key, Input
input) -> do
        let at_time :: TrackTime
at_time = TrackTime
0
        (Either Text (Either PitchError NoteNumber)
val, [Msg]
logs) <- forall (m :: * -> *) a.
M m =>
BlockId -> TrackId -> Deriver a -> m (Either Text a, [Msg])
Perf.derive_at BlockId
block_id TrackId
track_id forall a b. (a -> b) -> a -> b
$
            Scale
-> TrackTime -> Input -> Deriver (Either PitchError NoteNumber)
Scale.scale_input_to_nn Scale
scale TrackTime
at_time Input
input
        let prefix :: Text -> Text
prefix = ((Text
"key " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Key
key forall a. Semigroup a => a -> a -> a
<> Text
": ") <>)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
prefix forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Text
pretty [Msg]
logs)) forall a b. (a -> b) -> a -> b
$ case Either Text (Either PitchError NoteNumber)
val of
            Left Text
err -> (forall a. Maybe a
Nothing, [Text
err])
            Right (Left PitchError
err) -> (forall a. Maybe a
Nothing, [forall a. Pretty a => a -> Text
pretty PitchError
err])
            Right (Right NoteNumber
nn) -> (forall a. a -> Maybe a
Just (Key
key, NoteNumber
nn), [])
    let name :: Text
name = forall a. Pretty a => a -> Text
pretty (Scale -> ScaleId
Scale.scale_id Scale
scale)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> [(Key, NoteNumber)] -> Scale
Patch.make_scale Text
name (forall a. [Maybe a] -> [a]
Maybe.catMaybes [Maybe (Key, NoteNumber)]
key_nns), forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Text]]
errs)

-- | Create a Patch.Scale for the named scale.
named :: Cmd.M m => Bool
    -- ^ False to check for warnings and errors, True to ignore them.
    -> Text -> Text -> m Patch.Scale
named :: forall (m :: * -> *). M m => Bool -> Text -> Text -> m Scale
named Bool
ignore_errors Text
name Text
transform = do
    Scale
scale <- forall (m :: * -> *). M m => Text -> m Scale
get_scale Text
name
    (Scale
scale, [Text]
errs) <- forall (m :: * -> *). M m => Scale -> Text -> m (Scale, [Text])
make_patch_scale Scale
scale Text
transform
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
ignore_errors Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
errs) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines [Text]
errs
    forall (m :: * -> *) a. Monad m => a -> m a
return Scale
scale

get_scale :: Cmd.M m => Text -> m Scale.Scale
get_scale :: forall (m :: * -> *). M m => Text -> m Scale
get_scale Text
name =
    forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require (Text
"scale not found: " forall a. Semigroup a => a -> a -> a
<> Text
name)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => Environ -> ScaleId -> m (Maybe Scale)
Perf.lookup_scale_env forall a. Monoid a => a
mempty (Text -> ScaleId
Pitch.ScaleId Text
name)

make_patch_scale :: Cmd.M m => Scale.Scale -> Text -> m (Patch.Scale, [Text])
make_patch_scale :: forall (m :: * -> *). M m => Scale -> Text -> m (Scale, [Text])
make_patch_scale Scale
scale Text
transform = do
    ([Maybe (Key, NoteNumber)]
key_nns, [[Text]]
errs) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Key, Input)]
all_inputs forall a b. (a -> b) -> a -> b
$ \(Key
key, Input
input) -> do
        let at_time :: TrackTime
at_time = TrackTime
0
        (Maybe (Either PitchError NoteNumber)
val, [Text]
logs) <- forall (m :: * -> *) a. M m => Deriver a -> m (Maybe a, [Text])
derive forall a b. (a -> b) -> a -> b
$ forall a. Text -> Deriver a -> Deriver a
Equal.transform_expr Text
transform forall a b. (a -> b) -> a -> b
$
            Scale
-> TrackTime -> Input -> Deriver (Either PitchError NoteNumber)
Scale.scale_input_to_nn Scale
scale TrackTime
at_time Input
input
        let prefix :: Text -> Text
prefix = ((Text
"key " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Key
key forall a. Semigroup a => a -> a -> a
<> Text
": ") <>)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
prefix forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++ [Text]
logs)) forall a b. (a -> b) -> a -> b
$ case Maybe (Either PitchError NoteNumber)
val of
            Maybe (Either PitchError NoteNumber)
Nothing -> (forall a. Maybe a
Nothing, [])
            Just (Left PitchError
err) -> (forall a. Maybe a
Nothing, [forall a. Pretty a => a -> Text
pretty PitchError
err])
            Just (Right NoteNumber
nn) -> (forall a. a -> Maybe a
Just (Key
key, NoteNumber
nn), [])
    let name :: Text
name = forall a. Pretty a => a -> Text
pretty (Scale -> ScaleId
Scale.scale_id Scale
scale)
    forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> [(Key, NoteNumber)] -> Scale
Patch.make_scale Text
name (forall a. [Maybe a] -> [a]
Maybe.catMaybes [Maybe (Key, NoteNumber)]
key_nns), forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Text]]
errs)

derive :: Cmd.M m => Derive.Deriver a -> m (Maybe a, [Text])
derive :: forall (m :: * -> *) a. M m => Deriver a -> m (Maybe a, [Text])
derive Deriver a
deriver = do
    (Either Error a
val, State
_, [Msg]
logs) <- forall (m :: * -> *) a.
M m =>
Cache -> ScoreDamage -> Deriver a -> m (RunResult a)
PlayUtil.run forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty Deriver a
deriver
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either Error a
val of
        Left Error
err -> (forall a. Maybe a
Nothing, forall a. Pretty a => a -> Text
pretty Error
err forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Text
pretty [Msg]
logs)
        Right a
val -> (forall a. a -> Maybe a
Just a
val, forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Text
pretty [Msg]
logs)

all_inputs :: [(Midi.Key, Pitch.Input)]
all_inputs :: [(Key, Input)]
all_inputs =
    [(Key
key, NoteNumber -> Input
InputNote.nn_to_input (forall a. Num a => Key -> a
Midi.from_key Key
key)) | Key
key <- [Key
0..Key
127]]

set_scale :: Cmd.M m => Util.Instrument -> m ()
set_scale :: forall (m :: * -> *). M m => Text -> m ()
set_scale Text
inst = do
    Scale
scale <- forall (m :: * -> *). M m => Bool -> m Scale
selection Bool
True
    forall (m :: * -> *). M m => Scale -> Text -> m ()
LInst.set_scale Scale
scale Text
inst

-- * retune

-- | All instruments with initialization get the new scale.
retune :: Cmd.M m => Patch.Scale -> m [Util.Instrument]
retune :: forall (m :: * -> *). M m => Scale -> m [Text]
retune Scale
scale = do
    [Text]
insts <- forall (m :: * -> *). M m => m [Text]
LInst.list_midi
    [Maybe Initialization]
inits <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). M m => Instrument -> m (Maybe Initialization)
LInst.inst_initialization forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Instrument
Util.instrument) [Text]
insts
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
insts [Maybe Initialization]
inits) forall a b. (a -> b) -> a -> b
$ \(Text
inst, Maybe Initialization
init) -> case Maybe Initialization
init of
        Maybe Initialization
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
        Just Initialization
Patch.Tuning -> forall (m :: * -> *). M m => Text -> Scale -> m ()
realtime Text
inst Scale
scale forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [Text
inst]
        Just Initialization
Patch.NrpnTuning -> forall (m :: * -> *). M m => Text -> Scale -> m ()
nrpn Text
inst Scale
scale forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [Text
inst]

-- | Show tuning map for debugging.
get_tuning :: Cmd.M m => Util.Instrument -> Patch.Scale -> m Text
get_tuning :: forall (m :: * -> *). M m => Text -> Scale -> m Text
get_tuning Text
inst Scale
scale = do
    attr_map :: AttributeMap
attr_map@(Common.AttributeMap [(Attributes, ([Keyswitch], Maybe Keymap))]
amap) <- Patch -> AttributeMap
Patch.patch_attribute_map forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        forall (m :: * -> *).
(Stack, M m) =>
Instrument -> m (Patch, Config)
Cmd.get_midi_instrument (Text -> Instrument
Util.instrument Text
inst)
    let tuning :: [Maybe (Key, NoteNumber)]
tuning = Maybe AttributeMap -> Scale -> [Maybe (Key, NoteNumber)]
Patch.scale_tuning (forall a. a -> Maybe a
Just AttributeMap
attr_map) Scale
scale
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Text
pretty [(Attributes, ([Keyswitch], Maybe Keymap))]
amap
        , [Text
""]
        , forall a b. (a -> b) -> [a] -> [b]
map ([Text] -> Text
Text.unwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Text
pretty) (forall a. Int -> [a] -> [[a]]
Lists.chunked Int
6 [Maybe (Key, NoteNumber)]
tuning)
        ]

-- | Set the instrument's Scale to the given scale and send a MIDI tuning
-- message with 'LInst.initialize_realtime_tuning'.
realtime :: Cmd.M m => Util.Instrument -> Patch.Scale -> m ()
realtime :: forall (m :: * -> *). M m => Text -> Scale -> m ()
realtime Text
inst Scale
scale = do
    forall (m :: * -> *). M m => Scale -> Text -> m ()
LInst.set_scale Scale
scale Text
inst
    forall (m :: * -> *). M m => (Config -> Config) -> Text -> m ()
LInst.modify_midi_config_
        (Config :-> Maybe Initialization
Patch.initialization forall f a. Lens f a -> a -> f -> f
#= forall a. a -> Maybe a
Just Initialization
Patch.Tuning) Text
inst
    forall (m :: * -> *). M m => Instrument -> m ()
LInst.initialize_realtime_tuning (Text -> Instrument
Util.instrument Text
inst)

-- | Just like 'realtime', but send tuning via 'LInst.initialize_nrpn_tuning'.
nrpn :: Cmd.M m => Util.Instrument -> Patch.Scale -> m ()
nrpn :: forall (m :: * -> *). M m => Text -> Scale -> m ()
nrpn Text
inst Scale
scale = do
    forall (m :: * -> *). M m => Scale -> Text -> m ()
LInst.set_scale Scale
scale Text
inst
    forall (m :: * -> *). M m => (Config -> Config) -> Text -> m ()
LInst.modify_midi_config_
        (Config :-> Maybe Initialization
Patch.initialization forall f a. Lens f a -> a -> f -> f
#= forall a. a -> Maybe a
Just Initialization
Patch.NrpnTuning) Text
inst
    forall (m :: * -> *). M m => Instrument -> m ()
LInst.initialize_nrpn_tuning (Text -> Instrument
Util.instrument Text
inst)

-- | Write KSP to retune a 12TET patch.  Don't forget to do 'LInst.set_scale'
-- to configure the instrument.
write_ksp :: Maybe Util.Instrument -> FilePath -> Patch.Scale -> Cmd.CmdT IO ()
write_ksp :: Maybe Text -> FilePath -> Scale -> CmdT IO ()
write_ksp Maybe Text
maybe_inst FilePath
filename Scale
scale = do
    Maybe AttributeMap
attr_map <- case Maybe Text
maybe_inst of
        Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just Text
inst -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Patch -> AttributeMap
Patch.patch_attribute_map forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            forall (m :: * -> *).
(Stack, M m) =>
Instrument -> m (Patch, Config)
Cmd.get_midi_instrument (Text -> Instrument
Util.instrument Text
inst)
    Text
ksp <- forall (m :: * -> *) err a.
(Stack, M m) =>
(err -> Text) -> Either err a -> m a
Cmd.require_right forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ Maybe AttributeMap -> Scale -> Either Text Text
Kontakt.Util.tuning_ksp Maybe AttributeMap
attr_map Scale
scale
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> IO ()
Text.IO.writeFile FilePath
filename Text
ksp
    forall (m :: * -> *) a. Monad m => a -> m a
return ()

write_bali_scales_ksp :: Cmd.CmdT IO ()
write_bali_scales_ksp :: CmdT IO ()
write_bali_scales_ksp = do
    FilePath -> (Tuning -> Scale) -> CmdT IO ()
write_laras_ksp FilePath
"wayang" (Bool -> Laras -> Tuning -> Scale
Wayang.instrument_scale Bool
True Laras
Wayang.laras_sawan)
    FilePath -> (Tuning -> Scale) -> CmdT IO ()
write_laras_ksp FilePath
"legong"
        (Laras -> Tuning -> Scale
Legong.complete_instrument_scale Laras
Legong.laras_rambat)

write_laras_ksp :: FilePath -> (BaliScales.Tuning -> Patch.Scale)
    -> Cmd.CmdT IO ()
write_laras_ksp :: FilePath -> (Tuning -> Scale) -> CmdT IO ()
write_laras_ksp FilePath
name Tuning -> Scale
make = 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 (Maybe Text -> FilePath -> Scale -> CmdT IO ()
write_ksp forall a. Maybe a
Nothing))
    [ (FilePath
name forall a. Semigroup a => a -> a -> a
<> FilePath
"-umbang.ksp", Tuning -> Scale
make Tuning
BaliScales.Umbang)
    , (FilePath
name forall a. Semigroup a => a -> a -> a
<> FilePath
"-isep.ksp", Tuning -> Scale
make Tuning
BaliScales.Isep)
    ]