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

-- | Yamaha VL1 synthesizer.
module User.Elaforge.Instrument.Vl1 where
import           Data.Bits ((.&.))
import qualified Data.ByteString as B
import           Data.ByteString (ByteString)
import qualified Data.Either as Either
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO
import           Data.Word (Word8)

import qualified System.FilePath as FilePath
import           System.FilePath ((</>))
import qualified Text.Printf as Printf

import qualified Util.Doc as Doc
import qualified Util.Exceptions as Exceptions
import qualified Util.File as File
import qualified Util.Log as Log
import qualified Util.Seq as Seq

import qualified App.Config as Config
import qualified App.Path as Path
import qualified Cmd.Instrument.MidiInst as MidiInst
import qualified Cmd.Instrument.MidiInstDb as MidiInstDb
import qualified Derive.ScoreT as ScoreT
import qualified Instrument.Common as Common
import qualified Instrument.InstT as InstT
import qualified Instrument.Sysex as Sysex

import qualified Midi.CC as CC
import qualified Midi.Encode
import qualified Midi.Midi as Midi

import qualified Perform.Midi.Control as Control
import qualified Perform.Midi.Patch as Patch
import qualified User.Elaforge.Instrument.Vl1Spec as Vl1Spec

import           Global


synth_name :: InstT.SynthName
synth_name :: Text
synth_name = Text
"vl1"

load :: Path.AppDir -> IO (Maybe MidiInst.Synth)
load :: AppDir -> IO (Maybe Synth)
load = (Patch -> Code) -> Text -> Text -> AppDir -> IO (Maybe Synth)
MidiInstDb.load_synth (Code -> Patch -> Code
forall a b. a -> b -> a
const Code
forall a. Monoid a => a
mempty) Text
synth_name Text
"Yamaha Vl1"

-- | Read the patch file, scan the sysex dir, and save the results in a cache.
make_db :: Path.AppDir -> IO ()
make_db :: AppDir -> IO ()
make_db AppDir
app_dir = do
    let dir :: String
dir = AppDir -> Relative -> String
Path.to_absolute AppDir
app_dir Relative
Config.instrument_dir
            String -> String -> String
</> Text -> String
untxt Text
synth_name
    let dirs :: [String]
dirs = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
dir</>) [String
"vc", String
"sysex", String
"patchman1", String
"patchman2"]
    [Patch]
patches <- (String -> IO [Patch]) -> [String] -> IO [Patch]
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM String -> IO [Patch]
parse_dir [String]
dirs
    [Patch]
builtins <- String -> IO [Patch]
parse_builtins (String
dir String -> String -> String
</> String
builtin)
    AppDir -> Text -> [Patch] -> IO ()
MidiInstDb.save_synth AppDir
app_dir Text
synth_name ([Patch]
builtins [Patch] -> [Patch] -> [Patch]
forall a. [a] -> [a] -> [a]
++ [Patch]
patches)

builtin :: FilePath
builtin :: String
builtin = String
"vl1v2-factory/vl1_ver2.all"


-- * parse

-- | Write .syx and .rec files for the contents of the given file.
extract_syxs :: FilePath -> FilePath -> IO ()
extract_syxs :: String -> String -> IO ()
extract_syxs String
dir String
fn = do
    [ByteString]
syxs <- String -> IO [ByteString]
file_to_syx String
fn
    [(Int, ByteString)] -> ((Int, ByteString) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [ByteString] -> [(Int, ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [ByteString]
syxs) (((Int, ByteString) -> IO ()) -> IO ())
-> ((Int, ByteString) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
n, ByteString
syx) -> do
        let Right RMap
rec = ByteString -> Either String RMap
decode_sysex ByteString
syx
            Right Text
name = String -> RMap -> Either String Text
forall a. RecordVal a => String -> RMap -> Either String a
Sysex.get_rmap String
"name" RMap
rec
            fn :: String
fn = String
dir String -> String -> String
</> Int -> Text -> String
syx_fname Int
n Text
name
        String -> ByteString -> IO ()
B.writeFile (String
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".syx") ByteString
syx
        String -> String -> IO ()
writeFile (String
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".rec") ([String] -> String
unlines (RMap -> [String]
Sysex.show_flat RMap
rec))

syx_fname :: Int -> Text -> FilePath
syx_fname :: Int -> Text -> String
syx_fname Int
num Text
name =
    String -> Int -> String -> String
forall r. PrintfType r => String -> r
Printf.printf String
"%03d.%s" Int
num (Text -> String
untxt (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Text
MidiInstDb.clean_name Text
name)

send_to_buffer :: RMap -> Either String RMap
send_to_buffer = [RMap -> Either String RMap] -> RMap -> Either String RMap
forall (m :: * -> *) a. Monad m => [a -> m a] -> a -> m a
modify
    [ String -> Int -> RMap -> Either String RMap
put_int String
"memory type" Int
0x7f
    , String -> Int -> RMap -> Either String RMap
put_int String
"memory number" Int
0
    ]

send_to_patch :: Int -> RMap -> Either String RMap
send_to_patch Int
num = [RMap -> Either String RMap] -> RMap -> Either String RMap
forall (m :: * -> *) a. Monad m => [a -> m a] -> a -> m a
modify
    [ String -> Int -> RMap -> Either String RMap
put_int String
"memory type" Int
0
    , String -> Int -> RMap -> Either String RMap
put_int String
"memory number" Int
num
    ]

set_pitch_bend :: RMap -> Either String RMap
set_pitch_bend = [RMap -> Either String RMap] -> RMap -> Either String RMap
forall (m :: * -> *) a. Monad m => [a -> m a] -> a -> m a
modify
    [ String -> Int -> RMap -> Either String RMap
put_int String
"element.0.control.pitch.lower depth" (-Int
12)
    , String -> Int -> RMap -> Either String RMap
put_int String
"element.0.control.pitch.upper depth" Int
12
    , String -> Int -> RMap -> Either String RMap
put_int String
"element.1.control.pitch.lower depth" (-Int
12)
    , String -> Int -> RMap -> Either String RMap
put_int String
"element.1.control.pitch.upper depth" Int
12
    ]

modify :: Monad m => [a -> m a] -> a -> m a
modify :: forall (m :: * -> *) a. Monad m => [a -> m a] -> a -> m a
modify = ((a -> m a) -> (a -> m a) -> a -> m a)
-> (a -> m a) -> [a -> m a] -> a -> m a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a -> m a) -> (a -> m a) -> a -> m a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
(<=<) a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

put_int :: String -> Int -> Sysex.RMap -> Either String Sysex.RMap
put_int :: String -> Int -> RMap -> Either String RMap
put_int String
path Int
int = String -> Int -> RMap -> Either String RMap
forall a.
(Show a, RecordVal a) =>
String -> a -> RMap -> Either String RMap
Sysex.put_rmap String
path Int
int

parse_builtins :: FilePath -> IO [MidiInst.Patch]
parse_builtins :: String -> IO [Patch]
parse_builtins String
fn = do
    ([String]
warns, [Patch]
patches) <- [Either String Patch] -> ([String], [Patch])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers ([Either String Patch] -> ([String], [Patch]))
-> IO [Either String Patch] -> IO ([String], [Patch])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [Either String Patch]
parse_file String
fn
    (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> IO ()) -> (String -> Text) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
txt) [String]
warns
    [Patch] -> IO [Patch]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Patch] -> IO [Patch]) -> [Patch] -> IO [Patch]
forall a b. (a -> b) -> a -> b
$ (Control -> Patch -> Patch) -> [Control] -> [Patch] -> [Patch]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Control -> Patch -> Patch
initialize [Control
0..] [Patch]
patches
    where
    initialize :: Control -> Patch -> Patch
initialize Control
n = Patch :-> Patch
MidiInst.patch(Patch :-> Patch)
-> Lens Patch InitializePatch -> Lens Patch InitializePatch
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Patch InitializePatch
Patch.initialize
        #= Patch.initialize_midi (Midi.program_change 0 n)

parse_dir :: FilePath -> IO [MidiInst.Patch]
parse_dir :: String -> IO [Patch]
parse_dir String
dir = do
    [String]
fns <- (String -> Bool) -> String -> IO [String]
File.listRecursive (Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
True) String
dir
    ([String]
warns, [Patch]
patches) <- [Either String Patch] -> ([String], [Patch])
forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers ([Either String Patch] -> ([String], [Patch]))
-> ([[Either String Patch]] -> [Either String Patch])
-> [[Either String Patch]]
-> ([String], [Patch])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Either String Patch]] -> [Either String Patch]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Either String Patch]] -> ([String], [Patch]))
-> IO [[Either String Patch]] -> IO ([String], [Patch])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO [Either String Patch])
-> [String] -> IO [[Either String Patch]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO [Either String Patch]
parse_file [String]
fns
    (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> IO ()) -> (String -> Text) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
txt) [String]
warns
    [Patch] -> IO [Patch]
forall (m :: * -> *) a. Monad m => a -> m a
return [Patch]
patches

parse_file :: FilePath -> IO [Either String MidiInst.Patch]
parse_file :: String -> IO [Either String Patch]
parse_file String
fn = do
    [ByteString]
syxs <- String -> IO [ByteString]
file_to_syx String
fn
    Text
doc <- Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> IO (Maybe Text) -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text -> IO (Maybe Text)
forall a. IO a -> IO (Maybe a)
Exceptions.ignoreEnoent
        (String -> IO Text
Text.IO.readFile (String -> String -> String
FilePath.replaceExtension String
fn String
".txt"))
    let results :: [Either String Patch]
results = (ByteString -> Either String Patch)
-> [ByteString] -> [Either String Patch]
forall a b. (a -> b) -> [a] -> [b]
map (RMap -> Either String Patch
record_to_patch (RMap -> Either String Patch)
-> (ByteString -> Either String RMap)
-> ByteString
-> Either String Patch
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ByteString -> Either String RMap
decode_sysex) [ByteString]
syxs
    [Either String Patch] -> IO [Either String Patch]
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> String)
-> (Patch -> Patch) -> Either String Patch -> Either String Patch
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Integer -> String -> String
forall {a}. Show a => a -> String -> String
failed Integer
i) (String -> Text -> ByteString -> Patch -> Patch
combine String
fn Text
doc ByteString
syx) Either String Patch
result
        | (Integer
i, ByteString
syx, Either String Patch
result) <- [Integer]
-> [ByteString]
-> [Either String Patch]
-> [(Integer, ByteString, Either String Patch)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Integer
1..] [ByteString]
syxs [Either String Patch]
results
        ]
    where
    failed :: a -> String -> String
failed a
i String
msg = String
"parsing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg

combine :: FilePath -> Text -> ByteString -> MidiInst.Patch -> MidiInst.Patch
combine :: String -> Text -> ByteString -> Patch -> Patch
combine String
fn Text
doc ByteString
syx =
    (Patch :-> Common Code
MidiInst.common (Patch :-> Common Code)
-> (Common Code -> Common Code) -> Patch -> Patch
forall f a. Lens f a -> (a -> a) -> f -> f
%= String -> Common Code -> Common Code
forall a. String -> Common a -> Common a
Sysex.add_file String
fn)
    (Patch -> Patch) -> (Patch -> Patch) -> Patch -> Patch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lens Patch Doc
MidiInst.doc Lens Patch Doc -> Doc -> Patch -> Patch
forall f a. Lens f a -> a -> f -> f
#= Text -> Doc
Doc.Doc (Text -> Text
Text.strip Text
doc))
    (Patch -> Patch) -> (Patch -> Patch) -> Patch -> Patch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Patch :-> Patch
MidiInst.patch(Patch :-> Patch)
-> Lens Patch InitializePatch -> Lens Patch InitializePatch
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Patch InitializePatch
Patch.initialize Lens Patch InitializePatch -> InitializePatch -> Patch -> Patch
forall f a. Lens f a -> a -> f -> f
#=
        [Message] -> InitializePatch
Patch.InitializeMidi [ByteString -> Message
Midi.Encode.decode ByteString
syx])

decode_sysex :: ByteString -> Either String Sysex.RMap
decode_sysex :: ByteString -> Either String RMap
decode_sysex ByteString
bytes = (RMap, ByteString) -> RMap
forall a b. (a, b) -> a
fst ((RMap, ByteString) -> RMap)
-> Either String (RMap, ByteString) -> Either String RMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Specs -> ByteString -> Either String (RMap, ByteString)
Vl1Spec.decode Specs
Vl1Spec.patch_spec ByteString
bytes

encode_sysex :: Sysex.RMap -> Either String ByteString
encode_sysex :: RMap -> Either String ByteString
encode_sysex = (ByteString -> ByteString)
-> Either String ByteString -> Either String ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
append_suffix (Either String ByteString -> Either String ByteString)
-> (RMap -> Either String ByteString)
-> RMap
-> Either String ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Specs -> RMap -> Either String ByteString
Vl1Spec.encode Specs
Vl1Spec.patch_spec

file_to_syx :: FilePath -> IO [ByteString]
file_to_syx :: String -> IO [ByteString]
file_to_syx String
fn = (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString
add_extra_zero ([ByteString] -> [ByteString])
-> IO [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case String -> String
FilePath.takeExtension String
fn of
    String
".all" -> Maybe Control -> ByteString -> [ByteString]
split_1bk Maybe Control
forall a. Maybe a
Nothing (ByteString -> [ByteString]) -> IO ByteString -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
fn
    String
".1vc" -> ByteString -> [ByteString]
split_1vc (ByteString -> [ByteString]) -> IO ByteString -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
fn
    String
".1bk" -> Maybe Control -> ByteString -> [ByteString]
split_1bk Maybe Control
forall a. Maybe a
Nothing (ByteString -> [ByteString]) -> IO ByteString -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
fn
    String
".syx" -> ByteString -> [ByteString]
split_syx (ByteString -> [ByteString]) -> IO ByteString -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
fn
    String
".txt" -> [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    String
".rec" -> [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    String
_ -> Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text
"skipping " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. Show a => a -> Text
showt String
fn) IO () -> IO [ByteString] -> IO [ByteString]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    where
    -- | Convert .1vc format to .syx format.  Derived by looking at vlone70
    -- conversions with od.
    split_1vc :: ByteString -> [ByteString]
split_1vc ByteString
bytes = [Maybe Control -> ByteString -> ByteString
bytes_to_syx Maybe Control
forall a. Maybe a
Nothing (Int -> ByteString -> ByteString
B.drop Int
0xc00 ByteString
bytes)]
    split_syx :: ByteString -> [ByteString]
split_syx = (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Control -> ByteString
B.singleton Control
Midi.Encode.eox_byte)
        ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
B.null) ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Control -> ByteString -> [ByteString]
B.split Control
Midi.Encode.eox_byte

split_1bk :: Maybe Word8 -> ByteString -> [ByteString]
split_1bk :: Maybe Control -> ByteString -> [ByteString]
split_1bk Maybe Control
memory = (Control -> ByteString -> ByteString)
-> [Control] -> [ByteString] -> [ByteString]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Control
n -> Maybe Control -> ByteString -> ByteString
bytes_to_syx ((Control -> Control -> Control
forall a. Num a => a -> a -> a
+Control
n) (Control -> Control) -> Maybe Control -> Maybe Control
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Control
memory)) [Control
0..] ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
split
    where
    split :: ByteString -> [ByteString]
split ByteString
bytes = (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Control -> Bool) -> ByteString -> Bool
B.all (Control -> Control -> Bool
forall a. Eq a => a -> a -> Bool
==Control
0) (ByteString -> Bool)
-> (ByteString -> ByteString) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
B.take Int
20) ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$
        (Int -> ByteString) -> [Int] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> ByteString -> ByteString)
-> ByteString -> Int -> ByteString
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> ByteString -> ByteString
B.drop ByteString
bytes) [Int]
offsets
    offsets :: [Int]
offsets = [Int
0xc00, Int
0x1800..]

-- | For some reason, some sysexes come out with a 0 for device numbers, and
-- some omit it entirely.
add_extra_zero :: ByteString -> ByteString
add_extra_zero :: ByteString -> ByteString
add_extra_zero ByteString
bytes
    | ByteString -> ByteString -> Bool
B.isPrefixOf ByteString
short ByteString
bytes = ByteString
long ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> ByteString -> ByteString
B.drop (ByteString -> Int
B.length ByteString
short) ByteString
bytes
    | Bool
otherwise = ByteString
bytes
    where
    long :: ByteString
long = [Control] -> ByteString
B.pack [Control
0xf0, Control
Midi.yamaha_code, Control
0, Control
0x7a]
    short :: ByteString
short = [Control] -> ByteString
B.pack [Control
0xf0, Control
Midi.yamaha_code, Control
0x7a]

-- | Wrap sysex codes around the raw bytes.
bytes_to_syx :: Maybe Word8 -> ByteString -> ByteString
bytes_to_syx :: Maybe Control -> ByteString -> ByteString
bytes_to_syx Maybe Control
memory ByteString
bytes = ByteString -> ByteString
append_suffix (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
    Int -> ByteString
Vl1Spec.vl1_header (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
14 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size)
        -- memory type, memory number
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [Control] -> ByteString
B.pack ([Control] -> (Control -> [Control]) -> Maybe Control -> [Control]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Control
0x7f, Control
0] (\Control
n -> [Control
0, Control
n]) Maybe Control
memory)
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> Control -> ByteString
B.replicate Int
14 Control
0 -- padding
        ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> ByteString -> ByteString
B.take Int
size ByteString
bytes
    where size :: Int
size = Int
0xc1c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0x20

append_suffix :: ByteString -> ByteString
append_suffix :: ByteString -> ByteString
append_suffix ByteString
bytes = ByteString
bytes ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [Control] -> ByteString
B.pack [Control
checksum, Control
Midi.Encode.eox_byte]
    where
    -- Checksum is the 2s complement of 7bit sum of the data.
    checksum :: Control
checksum = (Control
2Control -> Integer -> Control
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
7 Control -> Control -> Control
forall a. Num a => a -> a -> a
- Control
val) Control -> Control -> Control
forall a. Bits a => a -> a -> a
.&. Control
0x7f
    -- Drop vl1_header but keep the magic string.
    val :: Control
val = (Control -> Control -> Control) -> Control -> ByteString -> Control
forall a. (a -> Control -> a) -> a -> ByteString -> a
B.foldl Control -> Control -> Control
forall a. Num a => a -> a -> a
(+) Control
0 (Int -> ByteString -> ByteString
B.drop Int
6 ByteString
bytes)

checksum :: ByteString -> Word8
checksum :: ByteString -> Control
checksum ByteString
bytes = (Control
2Control -> Integer -> Control
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
7 Control -> Control -> Control
forall a. Num a => a -> a -> a
- Control
val) Control -> Control -> Control
forall a. Bits a => a -> a -> a
.&. Control
0x7f
    where
    suf :: ByteString
suf = Int -> ByteString -> ByteString
B.drop Int
6 ByteString
bytes
    bs :: ByteString
bs = Int -> ByteString -> ByteString
B.take (ByteString -> Int
B.length ByteString
suf Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) ByteString
suf
    val :: Control
val = (Control -> Control -> Control) -> Control -> ByteString -> Control
forall a. (a -> Control -> a) -> a -> ByteString -> a
B.foldl Control -> Control -> Control
forall a. Num a => a -> a -> a
(+) Control
0 ByteString
bs

-- * record

-- | Each voice has two elements, each with their own PbRange, name, and
-- controls.
type ElementInfo = (Control.PbRange, Text, [(Midi.Control, [ScoreT.Control])])

record_to_patch :: Sysex.RMap -> Either String MidiInst.Patch
record_to_patch :: RMap -> Either String Patch
record_to_patch RMap
rmap = do
    Text
name <- String -> Either String Text
forall a. RecordVal a => String -> Either String a
get String
"name"
    ElementInfo
elt1 <- Int -> RMap -> Either String ElementInfo
extract_element Int
0 RMap
rmap
    Maybe ElementInfo
maybe_elt2 <- Either String Bool
-> Either String (Maybe ElementInfo)
-> Either String (Maybe ElementInfo)
-> Either String (Maybe ElementInfo)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== (Text
"dual" :: Text)) (Text -> Bool) -> Either String Text -> Either String Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Either String Text
forall a. RecordVal a => String -> Either String a
get String
"voice mode")
        (ElementInfo -> Maybe ElementInfo
forall a. a -> Maybe a
Just (ElementInfo -> Maybe ElementInfo)
-> Either String ElementInfo -> Either String (Maybe ElementInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> RMap -> Either String ElementInfo
extract_element Int
1 RMap
rmap)
        (Maybe ElementInfo -> Either String (Maybe ElementInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ElementInfo
forall a. Maybe a
Nothing)
    Patch -> Either String Patch
forall (m :: * -> *) a. Monad m => a -> m a
return (Patch -> Either String Patch) -> Patch -> Either String Patch
forall a b. (a -> b) -> a -> b
$ Text -> ElementInfo -> Maybe ElementInfo -> Patch
vl1_patch Text
name ElementInfo
elt1 Maybe ElementInfo
maybe_elt2
    where
    get :: Sysex.RecordVal a => String -> Either String a
    get :: forall a. RecordVal a => String -> Either String a
get = (String -> RMap -> Either String a)
-> RMap -> String -> Either String a
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> RMap -> Either String a
forall a. RecordVal a => String -> RMap -> Either String a
Sysex.get_rmap RMap
rmap

vl1_patch :: InstT.Name -> ElementInfo -> Maybe ElementInfo -> MidiInst.Patch
vl1_patch :: Text -> ElementInfo -> Maybe ElementInfo -> Patch
vl1_patch Text
name ElementInfo
elt1 Maybe ElementInfo
maybe_elt2 =
    (if Bool
is_pressure then Patch -> Patch
MidiInst.pressure else Patch -> Patch
forall a. a -> a
id) (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$
        Patch :-> Common Code
MidiInst.common(Patch :-> Common Code)
-> Lens (Common Code) [Tag] -> Lens Patch [Tag]
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens (Common Code) [Tag]
forall {code}. Common code :-> [Tag]
Common.tags Lens Patch [Tag] -> [Tag] -> Patch -> Patch
forall f a. Lens f a -> a -> f -> f
#= (Text -> Tag) -> [Text] -> [Tag]
forall a b. (a -> b) -> [a] -> [b]
map ((,) Text
"vl1-element") [Text]
names (Patch -> Patch) -> Patch -> Patch
forall a b. (a -> b) -> a -> b
$
        PbRange -> Text -> [(Control, Control)] -> Patch
MidiInst.named_patch PbRange
pb_range Text
name [(Control, Control)]
cmap
    where
    ([PbRange]
pb_ranges, [Text]
names, [[(Control, [Control])]]
cc_groups) = [ElementInfo] -> ([PbRange], [Text], [[(Control, [Control])]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([ElementInfo] -> ([PbRange], [Text], [[(Control, [Control])]]))
-> [ElementInfo] -> ([PbRange], [Text], [[(Control, [Control])]])
forall a b. (a -> b) -> a -> b
$ ElementInfo
elt1 ElementInfo -> [ElementInfo] -> [ElementInfo]
forall a. a -> [a] -> [a]
: Maybe ElementInfo -> [ElementInfo]
forall a. Maybe a -> [a]
Maybe.maybeToList Maybe ElementInfo
maybe_elt2
    -- If it has a pressure control, then assume it's a breath patch.
    is_pressure :: Bool
is_pressure = Control
CC.breath Control -> [Control] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((Control, Control) -> Control)
-> [(Control, Control)] -> [Control]
forall a b. (a -> b) -> [a] -> [b]
map (Control, Control) -> Control
forall a b. (a, b) -> a
fst [(Control, Control)]
cmap

    -- Optimistically take the widest range.
    Just PbRange
pb_range = (PbRange -> Int) -> [PbRange] -> Maybe PbRange
forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Seq.maximum_on (\(Int
low, Int
high) -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Int -> Int
forall a. Num a => a -> a
abs Int
low) (Int -> Int
forall a. Num a => a -> a
abs Int
high))
        [PbRange]
pb_ranges
    cmap :: [(Control, Control)]
cmap = Map Control Control -> [(Control, Control)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Control Control -> [(Control, Control)])
-> Map Control Control -> [(Control, Control)]
forall a b. (a -> b) -> a -> b
$ ([Control] -> Maybe Control)
-> Map Control [Control] -> Map Control Control
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe [Control] -> Maybe Control
forall {t :: * -> *}. Foldable t => t Control -> Maybe Control
highest_prio (Map Control [Control] -> Map Control Control)
-> Map Control [Control] -> Map Control Control
forall a b. (a -> b) -> a -> b
$
        ([Control] -> [Control] -> [Control])
-> [Map Control [Control]] -> Map Control [Control]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith [Control] -> [Control] -> [Control]
forall a. [a] -> [a] -> [a]
(++) (([(Control, [Control])] -> Map Control [Control])
-> [[(Control, [Control])]] -> [Map Control [Control]]
forall a b. (a -> b) -> [a] -> [b]
map [(Control, [Control])] -> Map Control [Control]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [[(Control, [Control])]]
cc_groups)
    highest_prio :: t Control -> Maybe Control
highest_prio t Control
cs = (Control -> Bool) -> [Control] -> Maybe Control
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (Control -> t Control -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Control
cs)
        (((Text, Bool) -> Control) -> [(Text, Bool)] -> [Control]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Control
ScoreT.unchecked_control (Text -> Control)
-> ((Text, Bool) -> Text) -> (Text, Bool) -> Control
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Bool) -> Text
forall a b. (a, b) -> a
fst) [(Text, Bool)]
vl1_control_map)

extract_element :: Int -> Sysex.RMap -> Either String ElementInfo
extract_element :: Int -> RMap -> Either String ElementInfo
extract_element Int
n RMap
rmap = do
    [(Text, Control, [Control])]
controls <- [(Text, Bool)]
-> ((Text, Bool) -> Either String (Text, Control, [Control]))
-> Either String [(Text, Control, [Control])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Text, Bool)]
vl1_control_map (((Text, Bool) -> Either String (Text, Control, [Control]))
 -> Either String [(Text, Control, [Control])])
-> ((Text, Bool) -> Either String (Text, Control, [Control]))
-> Either String [(Text, Control, [Control])]
forall a b. (a -> b) -> a -> b
$ \(Text
name, Bool
has_upper_lower) -> do
        Control
cc <- [Text] -> Either String Control
forall a. RecordVal a => [Text] -> Either String a
get [Text
"control", Text
name, Text
"control"]
        [Control]
depths <- if Bool
has_upper_lower
            then do
                Control
upper <- [Text] -> Either String Control
forall a. RecordVal a => [Text] -> Either String a
get [Text
"control", Text
name, Text
"upper depth"]
                Control
lower <- [Text] -> Either String Control
forall a. RecordVal a => [Text] -> Either String a
get [Text
"control", Text
name, Text
"lower depth"]
                [Control] -> Either String [Control]
forall (m :: * -> *) a. Monad m => a -> m a
return [Control
upper, Control
lower]
            else (Control -> [Control] -> [Control]
forall a. a -> [a] -> [a]
:[]) (Control -> [Control])
-> Either String Control -> Either String [Control]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> Either String Control
forall a. RecordVal a => [Text] -> Either String a
get [Text
"control", Text
name, Text
"depth"]
        (Text, Control, [Control])
-> Either String (Text, Control, [Control])
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text
clean Text
name, Control
cc, [Control]
depths)
    Int
pb_up <- [Text] -> Either String Int
forall a. RecordVal a => [Text] -> Either String a
get [Text
"control", Text
"pitch", Text
"upper depth"]
    Int
pb_down <- [Text] -> Either String Int
forall a. RecordVal a => [Text] -> Either String a
get [Text
"control", Text
"pitch", Text
"lower depth"]
    Text
name <- [Text] -> Either String Text
forall a. RecordVal a => [Text] -> Either String a
get [Text
"name"]
    ElementInfo -> Either String ElementInfo
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int
pb_up, Int
pb_down), Text
name, [(Text, Control, [Control])] -> [(Control, [Control])]
process_controls [(Text, Control, [Control])]
controls)
    where
    get :: (Sysex.RecordVal a) => [Text] -> Either String a
    get :: forall a. RecordVal a => [Text] -> Either String a
get [Text]
k = String -> RMap -> Either String a
forall a. RecordVal a => String -> RMap -> Either String a
Sysex.get_rmap
        (Text -> String
untxt (Text -> [Text] -> Text
Text.intercalate Text
"." ([Text
"element", Int -> Text
forall a. Show a => a -> Text
showt Int
n] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
k))) RMap
rmap
    -- The vl1 mostly uses the midi control list, except sticks some
    -- internal ones in there.  TODO 120 is aftertouch.
    valid_control :: a -> Bool
valid_control a
cc = a
cca -> a -> Bool
forall a. Ord a => a -> a -> Bool
>a
0 Bool -> Bool -> Bool
&& (a
cca -> a -> Bool
forall a. Ord a => a -> a -> Bool
<a
11 Bool -> Bool -> Bool
|| a
cca -> a -> Bool
forall a. Ord a => a -> a -> Bool
>a
15) Bool -> Bool -> Bool
&& a
cca -> a -> Bool
forall a. Ord a => a -> a -> Bool
<a
120
    clean :: Text -> Text
clean = (Char -> Char) -> Text -> Text
Text.map ((Char -> Char) -> Text -> Text) -> (Char -> Char) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ \Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' then Char
'-' else Char
c

    process_controls :: [(Text, Midi.Control, [Word8])]
        -> [(Midi.Control, [ScoreT.Control])]
    process_controls :: [(Text, Control, [Control])] -> [(Control, [Control])]
process_controls [(Text, Control, [Control])]
controls =
        [(Control
cc, ((Control, Control) -> Control)
-> [(Control, Control)] -> [Control]
forall a b. (a -> b) -> [a] -> [b]
map (Control, Control) -> Control
forall a b. (a, b) -> b
snd [(Control, Control)]
grp) | (Control
cc, [(Control, Control)]
grp) <- ((Control, Control) -> Control)
-> [(Control, Control)] -> [(Control, [(Control, Control)])]
forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])]
Seq.keyed_group_sort (Control, Control) -> Control
forall a b. (a, b) -> a
fst [(Control, Control)]
by_cc]
        where
        by_cc :: [(Control, Control)]
by_cc =
            [ (Control
cc, Text -> Control
ScoreT.unchecked_control Text
name)
            | (Text
name, Control
cc, [Control]
depths) <- [(Text, Control, [Control])]
controls, Control -> Bool
forall {a}. (Ord a, Num a) => a -> Bool
valid_control Control
cc
            , [Control] -> Control
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((Control -> Control) -> [Control] -> [Control]
forall a b. (a -> b) -> [a] -> [b]
map Control -> Control
forall a. Num a => a -> a
abs [Control]
depths) Control -> Control -> Bool
forall a. Ord a => a -> a -> Bool
>= Control
32
            ]

-- | Vaguely \"more audible\" controls come first.  Having more than one seq
-- control affecting the same vl1 control is confusing, so when a control is
-- assigned to more than one control, the one first in this list will get
-- the control.  That way, if contoller 2 is assigned to both pressure and
-- amplitude, the control will be called @pressure@.
--
-- Of course prominence is also highly dependent on depth, but this is simpler.
-- I ignore controls below a certain depth anyway.
--
-- Paired with the byte offset in the @element parameters@ sysex section.
vl1_control_map :: [(Text, Bool)]
vl1_control_map :: [(Text, Bool)]
vl1_control_map =
    [ (Text
"embouchure", Bool
True)
    , (Text
"pressure", Bool
False)
    , (Text
"amplitude", Bool
False)
    , (Text
"scream", Bool
False)
    , (Text
"growl", Bool
False)
    , (Text
"vibrato", Bool
False)
    , (Text
"dynamic filter", Bool
False)
    , (Text
"throat formant", Bool
False)
    , (Text
"breath noise", Bool
False)
    , (Text
"harmonic enhancer", Bool
False)
    , (Text
"tonguing", Bool
False)
    , (Text
"damping", Bool
False)
    , (Text
"absorption", Bool
False)
    ]