-- 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.Files as Files
import qualified Util.Log as Log
import qualified Util.Lists as Lists

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 (forall a b. a -> b -> a
const 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 = forall a b. (a -> b) -> [a] -> [b]
map (String
dir</>) [String
"vc", String
"sysex", String
"patchman1", String
"patchman2"]
    [Patch]
patches <- 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 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
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [ByteString]
syxs) 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 = 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 forall a. [a] -> [a] -> [a]
++ String
".syx") ByteString
syx
        String -> String -> IO ()
writeFile (String
fn 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 =
    forall r. PrintfType r => String -> r
Printf.printf String
"%03d.%s" Int
num (Text -> String
untxt forall a b. (a -> b) -> a -> b
$ Text -> Text
MidiInstDb.clean_name Text
name)

send_to_buffer :: RMap -> Either String RMap
send_to_buffer = 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 = 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 = 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
(<=<) 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 = 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) <- forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [Either String Patch]
parse_file String
fn
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
txt) [String]
warns
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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.patchforall a b c. Lens a b -> Lens b c -> Lens a c
#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]
Files.listRecursive (forall a b. a -> b -> a
const Bool
True) String
dir
    ([String]
warns, [Patch]
patches) <- forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
txt) [String]
warns
    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 <- forall a. a -> Maybe a -> a
fromMaybe Text
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall a b. (a -> b) -> [a] -> [b]
map (RMap -> Either String Patch
record_to_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
    forall (m :: * -> *) a. Monad m => a -> m a
return
        [ forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (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) <- 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 " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
fn forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
i forall a. [a] -> [a] -> [a]
++ 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 forall f a. Lens f a -> (a -> a) -> f -> f
%= forall a. String -> Common a -> Common a
Sysex.add_file String
fn)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lens Patch Doc
MidiInst.doc forall f a. Lens f a -> a -> f -> f
#= Text -> Doc
Doc.Doc (Text -> Text
Text.strip Text
doc))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Patch :-> Patch
MidiInst.patchforall a b c. Lens a b -> Lens b c -> Lens a c
#Patch :-> InitializePatch
Patch.initialize 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 = forall a b. (a, b) -> a
fst 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
append_suffix 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 = forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString
add_extra_zero 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 forall a. Maybe a
Nothing 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 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 forall a. Maybe a
Nothing 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
fn
    String
".txt" -> forall (m :: * -> *) a. Monad m => a -> m a
return []
    String
".rec" -> forall (m :: * -> *) a. Monad m => a -> m a
return []
    String
_ -> forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text
"skipping " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt String
fn) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 forall a. Maybe a
Nothing (Int -> ByteString -> ByteString
B.drop Int
0xc00 ByteString
bytes)]
    split_syx :: ByteString -> [ByteString]
split_syx = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Semigroup a => a -> a -> a
<> Control -> ByteString
B.singleton Control
Midi.Encode.eox_byte)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
B.null) 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 = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Control
n -> Maybe Control -> ByteString -> ByteString
bytes_to_syx ((forall a. Num a => a -> a -> a
+Control
n) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Control
memory)) [Control
0..] forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
split
    where
    split :: ByteString -> [ByteString]
split ByteString
bytes = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Control -> Bool) -> ByteString -> Bool
B.all (forall a. Eq a => a -> a -> Bool
==Control
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
B.take Int
20) forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (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 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 forall a b. (a -> b) -> a -> b
$
    Int -> ByteString
Vl1Spec.vl1_header (Int
2 forall a. Num a => a -> a -> a
+ Int
14 forall a. Num a => a -> a -> a
+ Int
size)
        -- memory type, memory number
        forall a. Semigroup a => a -> a -> a
<> [Control] -> ByteString
B.pack (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Control
0x7f, Control
0] (\Control
n -> [Control
0, Control
n]) Maybe Control
memory)
        forall a. Semigroup a => a -> a -> a
<> Int -> Control -> ByteString
B.replicate Int
14 Control
0 -- padding
        forall a. Semigroup a => a -> a -> a
<> Int -> ByteString -> ByteString
B.take Int
size ByteString
bytes
    where size :: Int
size = Int
0xc1c forall a. Num a => a -> a -> a
- Int
0x20

append_suffix :: ByteString -> ByteString
append_suffix :: ByteString -> ByteString
append_suffix ByteString
bytes = ByteString
bytes 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
2forall a b. (Num a, Integral b) => a -> b -> a
^Integer
7 forall a. Num a => a -> a -> a
- Control
val) forall a. Bits a => a -> a -> a
.&. Control
0x7f
    -- Drop vl1_header but keep the magic string.
    val :: Control
val = forall a. (a -> Control -> a) -> a -> ByteString -> a
B.foldl 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
2forall a b. (Num a, Integral b) => a -> b -> a
^Integer
7 forall a. Num a => a -> a -> a
- Control
val) 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 forall a. Num a => a -> a -> a
- Int
2) ByteString
suf
    val :: Control
val = forall a. (a -> Control -> a) -> a -> ByteString -> a
B.foldl 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 <- 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 <- forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM ((forall a. Eq a => a -> a -> Bool
== (Text
"dual" :: Text)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. RecordVal a => String -> Either String a
get String
"voice mode")
        (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> RMap -> Either String ElementInfo
extract_element Int
1 RMap
rmap)
        (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
        Patch :-> Common Code
MidiInst.commonforall a b c. Lens a b -> Lens b c -> Lens a c
#forall {code}. Common code :-> [Tag]
Common.tags forall f a. Lens f a -> a -> f -> f
#= forall a b. (a -> b) -> [a] -> [b]
map ((,) Text
"vl1-element") [Text]
names 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) = forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 forall a b. (a -> b) -> a -> b
$ ElementInfo
elt1 forall a. a -> [a] -> [a]
: 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Control, Control)]
cmap

    -- Optimistically take the widest range.
    Just PbRange
pb_range = forall k a. Ord k => (a -> k) -> [a] -> Maybe a
Lists.maximumOn (\(Int
low, Int
high) -> forall a. Ord a => a -> a -> a
max (forall a. Num a => a -> a
abs Int
low) (forall a. Num a => a -> a
abs Int
high))
        [PbRange]
pb_ranges
    cmap :: [(Control, Control)]
cmap = forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe forall {t :: * -> *}. Foldable t => t Control -> Maybe Control
highest_prio forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall a. [a] -> [a] -> [a]
(++) (forall a b. (a -> b) -> [a] -> [b]
map 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Control
cs)
        (forall a b. (a -> b) -> [a] -> [b]
map (Text -> Control
ScoreT.Control forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Text, Bool)]
vl1_control_map forall a b. (a -> b) -> a -> b
$ \(Text
name, Bool
has_upper_lower) -> do
        Control
cc <- 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 <- forall a. RecordVal a => [Text] -> Either String a
get [Text
"control", Text
name, Text
"upper depth"]
                Control
lower <- forall a. RecordVal a => [Text] -> Either String a
get [Text
"control", Text
name, Text
"lower depth"]
                forall (m :: * -> *) a. Monad m => a -> m a
return [Control
upper, Control
lower]
            else (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. RecordVal a => [Text] -> Either String a
get [Text
"control", Text
name, Text
"depth"]
        forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text
clean Text
name, Control
cc, [Control]
depths)
    Int
pb_up <- forall a. RecordVal a => [Text] -> Either String a
get [Text
"control", Text
"pitch", Text
"upper depth"]
    Int
pb_down <- forall a. RecordVal a => [Text] -> Either String a
get [Text
"control", Text
"pitch", Text
"lower depth"]
    Text
name <- forall a. RecordVal a => [Text] -> Either String a
get [Text
"name"]
    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 = forall a. RecordVal a => String -> RMap -> Either String a
Sysex.get_rmap
        (Text -> String
untxt (Text -> [Text] -> Text
Text.intercalate Text
"." ([Text
"element", forall a. Show a => a -> Text
showt Int
n] 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
ccforall a. Ord a => a -> a -> Bool
>a
0 Bool -> Bool -> Bool
&& (a
ccforall a. Ord a => a -> a -> Bool
<a
11 Bool -> Bool -> Bool
|| a
ccforall a. Ord a => a -> a -> Bool
>a
15) Bool -> Bool -> Bool
&& a
ccforall a. Ord a => a -> a -> Bool
<a
120
    clean :: Text -> Text
clean = (Char -> Char) -> Text -> Text
Text.map forall a b. (a -> b) -> a -> b
$ \Char
c -> if Char
c 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, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Control, Control)]
grp) | (Control
cc, [(Control, Control)]
grp) <- forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])]
Lists.keyedGroupSort forall a b. (a, b) -> a
fst [(Control, Control)]
by_cc]
        where
        by_cc :: [(Control, Control)]
by_cc =
            [ (Control
cc, Text -> Control
ScoreT.Control Text
name)
            | (Text
name, Control
cc, [Control]
depths) <- [(Text, Control, [Control])]
controls, forall {a}. (Ord a, Num a) => a -> Bool
valid_control Control
cc
            , forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map forall a. Num a => a -> a
abs [Control]
depths) 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)
    ]