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

-- | Korg Z1 keyboard.
module User.Elaforge.Instrument.Z1 where
import qualified Data.Bits as Bits
import           Data.Bits ((.|.))
import qualified Data.ByteString as B
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as Char8
import qualified Data.Text as Text
import           Data.Word (Word8)

import           System.FilePath ((</>))

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.Encode
import qualified Midi.Midi as Midi
import qualified Perform.Midi.Patch as Patch

import           Global
import           User.Elaforge.Instrument.Z1Spec


synth_name :: InstT.SynthName
synth_name :: Name
synth_name = Name
"z1"

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

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
</> Name -> String
untxt Name
synth_name
    [Patch]
bank_a <- Int -> Parser [Patch] -> String -> IO [Patch]
Sysex.parse_builtins Int
0 Parser [Patch]
program_dump (String
dir String -> String -> String
</> String
"bank_a.syx")
    [Patch]
bank_b <- Int -> Parser [Patch] -> String -> IO [Patch]
Sysex.parse_builtins Int
1 Parser [Patch]
program_dump (String
dir String -> String -> String
</> String
"bank_b.syx")
    [Patch]
sysex <- [Parser [Patch]] -> String -> IO [Patch]
Sysex.parse_dir [Parser [Patch]
current_program_dump, Parser [Patch]
program_dump, Parser [Patch]
sysex_manager]
        (String
dir String -> String -> String
</> String
"sysex")
    AppDir -> Name -> [Patch] -> IO ()
MidiInstDb.save_synth AppDir
app_dir Name
synth_name ([Patch] -> IO ()) -> [Patch] -> IO ()
forall a b. (a -> b) -> a -> b
$
        (Patch -> Patch) -> [Patch] -> [Patch]
forall a b. (a -> b) -> [a] -> [b]
map (Patch -> Patch
override_pb (Patch -> Patch) -> (Patch -> Patch) -> Patch -> Patch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Patch -> Patch
MidiInst.patch_from_pair) ([Patch] -> [Patch]) -> [Patch] -> [Patch]
forall a b. (a -> b) -> a -> b
$
        [[Patch]] -> [Patch]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Patch]
bank_a, [Patch]
bank_b, [Patch]
sysex]
    where
    current_program_dump :: Parser [Patch]
current_program_dump =
        (Patch -> [Patch]) -> Either String Patch -> Either String [Patch]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Patch -> [Patch] -> [Patch]
forall a. a -> [a] -> [a]
:[]) (Either String Patch -> Either String [Patch])
-> (ByteString -> Either String Patch) -> Parser [Patch]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RMap -> Either String Patch
rmap_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_current_program)
    program_dump :: Parser [Patch]
program_dump = (RMap -> Either String Patch) -> [RMap] -> Either String [Patch]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM RMap -> Either String Patch
rmap_to_patch ([RMap] -> Either String [Patch])
-> (ByteString -> Either String [RMap]) -> Parser [Patch]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ByteString -> Either String [RMap]
decode_program_dump
    -- Each patch has its own pb range, but you can override them in the
    -- multiset.
    override_pb :: Patch -> Patch
override_pb = Patch :-> Patch
MidiInst.patch(Patch :-> Patch)
-> Lens Patch (Maybe PbRange) -> Lens Patch (Maybe PbRange)
forall a b c. Lens a b -> Lens b c -> Lens a c
#Patch :-> Settings
Patch.defaults(Patch :-> Settings)
-> Lens Settings (Maybe PbRange) -> Lens Patch (Maybe PbRange)
forall a b c. Lens a b -> Lens b c -> Lens a c
#Lens Settings (Maybe PbRange)
Patch.pitch_bend_range
        #= Just (-24, 24)

synth_controls :: [(Midi.Control, ScoreT.Control)]
synth_controls :: [(Word8, Control)]
synth_controls =
    -- The PE controls are the "performance expression" knobs whose effect
    -- depends on the instrument.
    [ (Word8
19, Control
"knob1"), (Word8
20, Control
"knob2"), (Word8
21, Control
"knob3"), (Word8
22, Control
"knob4"), (Word8
23, Control
"knob5")
    , (Word8
16, Control
"pad-x"), (Word8
17, Control
"pad-y")
    , (Word8
65, Control
"port-sw") -- Turn portamento on and off.
    , (Word8
80, Control
"sw1"), (Word8
81, Control
"sw2") -- General purpose on/off switches.
    -- filter 1
    , (Word8
85, Control
"filter1-cutoff"), (Word8
86, Control
"filter1-q"), (Word8
87, Control
"filter1-eg")
    , (Word8
24, Control
"filter1-attack"), (Word8
25, Control
"filter1-decay"), (Word8
26, Control
"filter1-sustain")
    , (Word8
27, Control
"filter1-release")
    -- filter 2
    , (Word8
88, Control
"filter2-cutoff"), (Word8
89, Control
"filter2-q"), (Word8
90, Control
"filter2-eg")
    , (Word8
28, Control
"filter2-attack"), (Word8
29, Control
"filter2-decay"), (Word8
30, Control
"filter2-sustain")
    , (Word8
31, Control
"filter2-release")
    -- amp
    , (Word8
76, Control
"amp-attack"), (Word8
77, Control
"amp-decay"), (Word8
78, Control
"amp-sustain")
    , (Word8
79, Control
"amp-release")
    ]

-- * decode sysex

decode_current_program :: ByteString -> Either String Sysex.RMap
decode_current_program :: ByteString -> Either String RMap
decode_current_program ByteString
bytes = do
    (RMap
header, ByteString
bytes) <- Specs -> ByteString -> Either String (RMap, ByteString)
decode Specs
current_program_dump_header ByteString
bytes
    (RMap
rmap, ByteString
_) <- Specs -> ByteString -> Either String (RMap, ByteString)
decode Specs
patch_spec (ByteString -> ByteString
dekorg ByteString
bytes)
    RMap -> Either String RMap
forall (m :: * -> *) a. Monad m => a -> m a
return (RMap -> Either String RMap) -> RMap -> Either String RMap
forall a b. (a -> b) -> a -> b
$ RMap
header RMap -> RMap -> RMap
forall a. Semigroup a => a -> a -> a
<> RMap
rmap

-- | Decode a dump for a program at a certain memory location.  This also
-- parses bank dumps, which are just encoded as a bunch of dumps at consecutive
-- memory locations.
decode_program_dump :: ByteString -> Either String [Sysex.RMap]
decode_program_dump :: ByteString -> Either String [RMap]
decode_program_dump ByteString
bytes = do
    -- If there is just one, then the bank and unit fields are valid.
    -- Otherwise, they are 0.
    (RMap
rmap, ByteString
bytes) <- Specs -> ByteString -> Either String (RMap, ByteString)
decode Specs
program_dump_header ByteString
bytes
    let syxs :: [ByteString]
syxs = Int -> ByteString -> [ByteString]
exact_chunks
            (Specs -> Int
spec_bytes Specs
patch_spec) (ByteString -> ByteString
dekorg ByteString
bytes)
    (ByteString -> Either String RMap)
-> [ByteString] -> Either String [RMap]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (((RMap, ByteString) -> RMap)
-> Either String (RMap, ByteString) -> Either String RMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RMap
rmap <>) (RMap -> RMap)
-> ((RMap, ByteString) -> RMap) -> (RMap, ByteString) -> RMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RMap, ByteString) -> RMap
forall a b. (a, b) -> a
fst) (Either String (RMap, ByteString) -> Either String RMap)
-> (ByteString -> Either String (RMap, ByteString))
-> ByteString
-> Either String RMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Specs -> ByteString -> Either String (RMap, ByteString)
decode Specs
patch_spec) [ByteString]
syxs

sysex_manager :: ByteString -> Either String [(Patch.Patch, Common.Common ())]
sysex_manager :: Parser [Patch]
sysex_manager ByteString
bytes = do
    ByteString
bytes <- ByteString -> ByteString -> Either String ByteString
Sysex.expect_bytes ByteString
bytes (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
Char8.pack String
"Sysex Manager"
    -- The first sysex is something else.
    let sysexes :: [ByteString]
sysexes = Int -> [ByteString] -> [ByteString]
forall a. Int -> [a] -> [a]
drop Int
1 ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
Sysex.extract_sysex ByteString
bytes
    [Patch]
patches <- (ByteString -> Either String Patch)
-> [ByteString] -> Either String [Patch]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RMap -> Either String Patch
rmap_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_current_program) [ByteString]
sysexes
    -- Add the initialize here, since 'bytes' isn't actually a valid sysex.
    [Patch] -> Either String [Patch]
forall (m :: * -> *) a. Monad m => a -> m a
return [(ByteString -> Patch -> Patch
Sysex.initialize_sysex ByteString
sysex Patch
patch, Common ()
common)
        | (ByteString
sysex, (Patch
patch, Common ()
common)) <- [ByteString] -> [Patch] -> [(ByteString, Patch)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ByteString]
sysexes [Patch]
patches]

test_decode :: IO (Either String RMap)
test_decode = do
    -- let fn = "inst_db/z1/sysex/lib2/apollo44.syx"
    -- let fn = "inst_db/z1/sysex/lib1/z1 o00o00 Syncapacitor.syx"
    -- let fn = "inst_db/z1/sysex/lib1/z1 o00o05 Composite Synth.syx"
    let fn :: String
fn = String
"inst_db/z1/sysex/lib1/z1 o00o00 .C.H.A.O.S..syx"
    ByteString -> Either String RMap
decode_current_program (ByteString -> Either String RMap)
-> IO ByteString -> IO (Either String RMap)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
fn

-- * encode sysex

-- set_pitch_bend fn = do
--     bytes <- B.readFile fn
--     records <- require "parse" $ decode_program_dump bytes
--     records <- require "set" $ mapM set records

set_bank_pitch_bend :: Bank -> FilePath -> IO ()
set_bank_pitch_bend :: Bank -> String -> IO ()
set_bank_pitch_bend Bank
bank String
fn = do
    ByteString
bytes <- String -> IO ByteString
B.readFile String
fn
    [RMap]
records <- Name -> Either String [RMap] -> IO [RMap]
forall {m :: * -> *} {a}.
MonadIO m =>
Name -> Either String a -> m a
require Name
"parse" (Either String [RMap] -> IO [RMap])
-> Either String [RMap] -> IO [RMap]
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String [RMap]
decode_program_dump ByteString
bytes
    [RMap]
records <- Name -> Either String [RMap] -> IO [RMap]
forall {m :: * -> *} {a}.
MonadIO m =>
Name -> Either String a -> m a
require Name
"set" (Either String [RMap] -> IO [RMap])
-> Either String [RMap] -> IO [RMap]
forall a b. (a -> b) -> a -> b
$ (RMap -> Either String RMap) -> [RMap] -> Either String [RMap]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM RMap -> Either String RMap
set [RMap]
records
    ByteString
bytes <- Name -> Either String ByteString -> IO ByteString
forall {m :: * -> *} {a}.
MonadIO m =>
Name -> Either String a -> m a
require Name
"unparse" (Either String ByteString -> IO ByteString)
-> Either String ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Unit -> Bank -> [RMap] -> Either String ByteString
encode_bank_dump Unit
All Bank
bank [RMap]
records
    String -> ByteString -> IO ()
B.writeFile (String
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".modified") ByteString
bytes
    where
    set :: RMap -> Either String RMap
set = String -> Int -> RMap -> Either String RMap
forall a.
(Show a, RecordVal a) =>
String -> a -> RMap -> Either String RMap
Sysex.put_rmap String
"pitch bend.intensity +" (Int
24 :: Int)
        (RMap -> Either String RMap)
-> (RMap -> Either String RMap) -> RMap -> Either String RMap
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Int -> RMap -> Either String RMap
forall a.
(Show a, RecordVal a) =>
String -> a -> RMap -> Either String RMap
Sysex.put_rmap String
"pitch bend.intensity -" (-Int
24 :: Int)
    require :: Name -> Either String a -> m a
require Name
msg = (String -> m a) -> (a -> m a) -> Either String a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Name -> m a
forall (m :: * -> *) a. (Stack, MonadIO m) => Name -> m a
errorIO (Name -> m a) -> (String -> Name) -> String -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name
msg Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
": ") <>) (Name -> Name) -> (String -> Name) -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
txt) a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

encode_current_program :: Sysex.RMap -> Either String ByteString
encode_current_program :: RMap -> Either String ByteString
encode_current_program RMap
rmap =
    Either String ByteString
-> Either String ByteString -> Either String ByteString
encode_sysex (Specs -> RMap -> Either String ByteString
encode Specs
current_program_dump_header RMap
rmap)
        (Specs -> RMap -> Either String ByteString
encode Specs
patch_spec RMap
rmap)

encode_program_dump :: Sysex.RMap -> Either String ByteString
encode_program_dump :: RMap -> Either String ByteString
encode_program_dump RMap
rmap =
    Either String ByteString
-> Either String ByteString -> Either String ByteString
encode_sysex (Specs -> RMap -> Either String ByteString
encode Specs
program_dump_header RMap
rmap)
        (Specs -> RMap -> Either String ByteString
encode Specs
patch_spec RMap
rmap)

data Unit = Program | Bank | All deriving (Int -> Unit -> String -> String
[Unit] -> String -> String
Unit -> String
(Int -> Unit -> String -> String)
-> (Unit -> String) -> ([Unit] -> String -> String) -> Show Unit
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Unit] -> String -> String
$cshowList :: [Unit] -> String -> String
show :: Unit -> String
$cshow :: Unit -> String
showsPrec :: Int -> Unit -> String -> String
$cshowsPrec :: Int -> Unit -> String -> String
Show)
data Bank = A | B deriving (Int -> Bank -> String -> String
[Bank] -> String -> String
Bank -> String
(Int -> Bank -> String -> String)
-> (Bank -> String) -> ([Bank] -> String -> String) -> Show Bank
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Bank] -> String -> String
$cshowList :: [Bank] -> String -> String
show :: Bank -> String
$cshow :: Bank -> String
showsPrec :: Int -> Bank -> String -> String
$cshowsPrec :: Int -> Bank -> String -> String
Show)

encode_bank_dump :: Unit -> Bank -> [Sysex.RMap] -> Either String ByteString
encode_bank_dump :: Unit -> Bank -> [RMap] -> Either String ByteString
encode_bank_dump Unit
unit Bank
bank [RMap]
rmaps = do
    RMap
header_rmap <- RMap -> Either String RMap
set_bank (RMap -> Either String RMap) -> RMap -> Either String RMap
forall a b. (a -> b) -> a -> b
$ Specs -> RMap
Sysex.spec_to_rmap Specs
program_dump_header
    Either String ByteString
-> Either String ByteString -> Either String ByteString
encode_sysex (Specs -> RMap -> Either String ByteString
encode Specs
program_dump_header RMap
header_rmap)
        ((RMap -> Either String ByteString)
-> [RMap] -> Either String ByteString
forall (m :: * -> *) b a.
(Monad m, Monoid b) =>
(a -> m b) -> [a] -> m b
concatMapM (Specs -> RMap -> Either String ByteString
encode Specs
patch_spec) [RMap]
rmaps)
    where
    set_bank :: RMap -> Either String RMap
set_bank = String -> Name -> RMap -> Either String RMap
forall a.
(Show a, RecordVal a) =>
String -> a -> RMap -> Either String RMap
Sysex.put_rmap String
"bank" (Name -> Name
Text.toLower (Bank -> Name
forall a. Show a => a -> Name
showt Bank
bank))
        (RMap -> Either String RMap)
-> (RMap -> Either String RMap) -> RMap -> Either String RMap
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> Name -> RMap -> Either String RMap
forall a.
(Show a, RecordVal a) =>
String -> a -> RMap -> Either String RMap
Sysex.put_rmap String
"unit" (Name -> Name
Text.toLower (Unit -> Name
forall a. Show a => a -> Name
showt Unit
unit))

encode_sysex :: Either String ByteString -> Either String ByteString
    -> Either String ByteString
encode_sysex :: Either String ByteString
-> Either String ByteString -> Either String ByteString
encode_sysex Either String ByteString
encode_header Either String ByteString
encode_body = do
    ByteString
header <- Either String ByteString
encode_header
    ByteString
body <- Either String ByteString
encode_body
    ByteString -> Either String ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
header ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
enkorg ByteString
body ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word8 -> ByteString
B.singleton Word8
Midi.Encode.eox_byte

-- ** record

rmap_to_patch :: Sysex.RMap -> Either String (Patch.Patch, Common.Common ())
rmap_to_patch :: RMap -> Either String Patch
rmap_to_patch RMap
rmap = do
    Name
name <- String -> Either String Name
forall a. RecordVal a => String -> Either String a
get String
"name"
    Name
category <- String -> Either String Name
forall a. RecordVal a => String -> Either String a
get String
"category"
    PbRange
pb_range <- (,) (Int -> Int -> PbRange)
-> Either String Int -> Either String (Int -> PbRange)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Either String Int
forall a. RecordVal a => String -> Either String a
get String
"pitch bend.intensity -"
        Either String (Int -> PbRange)
-> Either String Int -> Either String PbRange
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Either String Int
forall a. RecordVal a => String -> Either String a
get String
"pitch bend.intensity +"
    Name
osc1 <- String -> Either String Name
forall a. RecordVal a => String -> Either String a
get String
"osc.0.type"
    Name
osc2 <- String -> Either String Name
forall a. RecordVal a => String -> Either String a
get String
"osc.1.type"
    let tags :: [(Name, Name)]
tags = [(Name
"category", Name
category), (Name
"z1-osc", Name
osc1), (Name
"z1-osc", Name
osc2)]
    let common :: Common ()
common = Common () :-> [(Name, Name)]
forall {code}. Common code :-> [(Name, Name)]
Common.tags (Common () :-> [(Name, Name)])
-> [(Name, Name)] -> Common () -> Common ()
forall f a. Lens f a -> a -> f -> f
#= [(Name, Name)]
tags (Common () -> Common ()) -> Common () -> Common ()
forall a b. (a -> b) -> a -> b
$ () -> Common ()
forall code. code -> Common code
Common.common ()
    Patch -> Either String Patch
forall (m :: * -> *) a. Monad m => a -> m a
return (PbRange -> Name -> Patch
Patch.patch PbRange
pb_range Name
name, Common ()
common)
    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

current_multi_data_dump :: Word8
current_multi_data_dump :: Word8
current_multi_data_dump = Word8
0x69

multi_data_dump :: Word8
multi_data_dump :: Word8
multi_data_dump = Word8
0x4d

-- | Z1 sysexes use a scheme where the eighth bits are packed into a single
-- byte preceeding its 7 7bit bytes.
dekorg :: ByteString -> ByteString
dekorg :: ByteString -> ByteString
dekorg = (ByteString -> ByteString) -> [ByteString] -> ByteString
forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap ByteString -> ByteString
smoosh ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> [ByteString]
chunks Int
8
    where
    smoosh :: ByteString -> ByteString
smoosh ByteString
bs = case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
bs of
        Just (Word8
b7, ByteString
bytes) -> (Int, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ((Int, ByteString) -> ByteString)
-> (Int, ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$
            (Int -> Word8 -> (Int, Word8))
-> Int -> ByteString -> (Int, ByteString)
forall acc.
(acc -> Word8 -> (acc, Word8))
-> acc -> ByteString -> (acc, ByteString)
B.mapAccumL (\Int
i Word8
to -> (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Word8 -> Int -> Word8 -> Word8
forall {a} {a}. (Bits a, Bits a) => a -> Int -> a -> a
copy_bit Word8
b7 Int
i Word8
to)) Int
0 ByteString
bytes
        Maybe (Word8, ByteString)
Nothing -> ByteString
forall a. Monoid a => a
mempty
    copy_bit :: a -> Int -> a -> a
copy_bit a
from Int
i a
to = if a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
Bits.testBit a
from Int
i
        then a -> Int -> a
forall a. Bits a => a -> Int -> a
Bits.setBit a
to Int
7 else a -> Int -> a
forall a. Bits a => a -> Int -> a
Bits.clearBit a
to Int
7

enkorg :: ByteString -> ByteString
enkorg :: ByteString -> ByteString
enkorg = (ByteString -> ByteString) -> [ByteString] -> ByteString
forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap ByteString -> ByteString
expand ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> [ByteString]
chunks Int
7
    where
    expand :: ByteString -> ByteString
expand ByteString
bs = Word8 -> ByteString -> ByteString
B.cons Word8
bits ((Word8 -> Word8) -> ByteString -> ByteString
B.map (Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`Bits.clearBit` Int
7) ByteString
bs)
        where bits :: Word8
bits = (Word8 -> Word8 -> Word8) -> Word8 -> ByteString -> Word8
forall a. (Word8 -> a -> a) -> a -> ByteString -> a
B.foldr Word8 -> Word8 -> Word8
forall {a} {a}. (Bits a, Bits a, Num a) => a -> a -> a
get_bits Word8
0 ByteString
bs
    get_bits :: a -> a -> a
get_bits a
b a
accum =
        a -> Int -> a
forall a. Bits a => a -> Int -> a
Bits.shiftL a
accum Int
1 a -> a -> a
forall a. Bits a => a -> a -> a
.|. (if a -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
Bits.testBit a
b Int
7 then a
1 else a
0)

chunks :: Int -> ByteString -> [ByteString]
chunks :: Int -> ByteString -> [ByteString]
chunks Int
size ByteString
bs
    | ByteString -> Bool
B.null ByteString
pre = []
    | Bool
otherwise = ByteString
pre ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: Int -> ByteString -> [ByteString]
chunks Int
size ByteString
post
    where (ByteString
pre, ByteString
post) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
size ByteString
bs

exact_chunks :: Int -> ByteString -> [ByteString]
exact_chunks :: Int -> ByteString -> [ByteString]
exact_chunks Int
size ByteString
bs
    | ByteString -> Int
B.length ByteString
pre Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
size = []
    | Bool
otherwise = ByteString
pre ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: Int -> ByteString -> [ByteString]
exact_chunks Int
size ByteString
post
    where (ByteString
pre, ByteString
post) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
size ByteString
bs

-- * test

test_multiset :: IO (Either String (RMap, ByteString))
test_multiset = do
    ByteString
bytes <- Int -> ByteString -> ByteString
B.drop Int
9 (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
"inst_db/multi1.syx"
    Either String (RMap, ByteString)
-> IO (Either String (RMap, ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (RMap, ByteString)
 -> IO (Either String (RMap, ByteString)))
-> Either String (RMap, ByteString)
-> IO (Either String (RMap, ByteString))
forall a b. (a -> b) -> a -> b
$ Specs -> ByteString -> Either String (RMap, ByteString)
decode Specs
multiset_spec (ByteString -> ByteString
dekorg ByteString
bytes)

test_dump :: IO (Either String [RMap])
test_dump = do
    ByteString
bytes <- String -> IO ByteString
B.readFile String
"inst_db/z1/bank_b.syx"
    Either String [RMap] -> IO (Either String [RMap])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String [RMap] -> IO (Either String [RMap]))
-> Either String [RMap] -> IO (Either String [RMap])
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String [RMap]
decode_program_dump ByteString
bytes

test_encode :: IO (Either String ByteString)
test_encode = do
    ByteString
bytes <- String -> IO ByteString
B.readFile String
"inst_db/z1/bank_b.syx"
    let Right [RMap]
recs = ByteString -> Either String [RMap]
decode_program_dump ByteString
bytes
    Either String ByteString -> IO (Either String ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String ByteString -> IO (Either String ByteString))
-> Either String ByteString -> IO (Either String ByteString)
forall a b. (a -> b) -> a -> b
$ Specs -> RMap -> Either String ByteString
encode Specs
patch_spec ([RMap] -> RMap
forall a. [a] -> a
head [RMap]
recs)

test_patch :: IO (Either String RMap)
test_patch = do
    ByteString
bytes <- String -> IO ByteString
B.readFile
        String
"inst_db/z1/sysex/lib1/z1 o00o00 ANALOG INIT.syx"
    Either String RMap -> IO (Either String RMap)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String RMap -> IO (Either String RMap))
-> Either String RMap -> IO (Either String RMap)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String RMap
decode_current_program ByteString
bytes

read_patch :: IO (Either String (RMap, ByteString))
read_patch = do
    ByteString
b <- ByteString -> ByteString
dekorg (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
B.drop Int
6 (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile
        String
"inst_db/z1/sysex/lib1/z1 o00o00 ANALOG INIT.syx"
    Either String (RMap, ByteString)
-> IO (Either String (RMap, ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (RMap, ByteString)
 -> IO (Either String (RMap, ByteString)))
-> Either String (RMap, ByteString)
-> IO (Either String (RMap, ByteString))
forall a b. (a -> b) -> a -> b
$ Specs -> ByteString -> Either String (RMap, ByteString)
decode Specs
patch_spec ByteString
b