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

-- | Types for modules.  Theoretically tracker-independent.
module Cmd.Load.ModT where
import qualified Data.Bits as Bits
import           Data.Bits ((.&.))
import qualified Data.IntMap as IntMap
import qualified Data.List as List
import qualified Data.Map as Map
import           Data.Word (Word8)

import qualified Util.Num as Num
import qualified Util.Lists as Lists
import qualified Derive.ScoreT as ScoreT
import qualified Perform.Pitch as Pitch

import           Global


data Module = Module {
    Module -> IntMap Instrument
_instruments :: IntMap Instrument
    , Module -> Tempo
_default_tempo :: !Tempo
    , Module -> [Block]
_blocks :: [Block]
    -- | Name of sequence, '_blocks' indices.
    , Module -> Map Text [Int]
_block_order :: Map Text [Int]
    } deriving (Module -> Module -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Module -> Module -> Bool
$c/= :: Module -> Module -> Bool
== :: Module -> Module -> Bool
$c== :: Module -> Module -> Bool
Eq, Int -> Module -> ShowS
[Module] -> ShowS
Module -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Module] -> ShowS
$cshowList :: [Module] -> ShowS
show :: Module -> String
$cshow :: Module -> String
showsPrec :: Int -> Module -> ShowS
$cshowsPrec :: Int -> Module -> ShowS
Show)

data Tempo = Tempo {
    Tempo -> Int
_speed :: !Int -- ^ could be BPM, or some tempo value
    , Tempo -> Int
_frames :: !Int -- ^ number of divisions per line
    } deriving (Tempo -> Tempo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tempo -> Tempo -> Bool
$c/= :: Tempo -> Tempo -> Bool
== :: Tempo -> Tempo -> Bool
$c== :: Tempo -> Tempo -> Bool
Eq, Int -> Tempo -> ShowS
[Tempo] -> ShowS
Tempo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tempo] -> ShowS
$cshowList :: [Tempo] -> ShowS
show :: Tempo -> String
$cshow :: Tempo -> String
showsPrec :: Int -> Tempo -> ShowS
$cshowsPrec :: Int -> Tempo -> ShowS
Show)

data Instrument = Instrument {
    Instrument -> Instrument
_instrument_name :: !ScoreT.Instrument
    , Instrument -> Maybe Double
_volume :: !(Maybe Double)
    } deriving (Instrument -> Instrument -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Instrument -> Instrument -> Bool
$c/= :: Instrument -> Instrument -> Bool
== :: Instrument -> Instrument -> Bool
$c== :: Instrument -> Instrument -> Bool
Eq, Int -> Instrument -> ShowS
[Instrument] -> ShowS
Instrument -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Instrument] -> ShowS
$cshowList :: [Instrument] -> ShowS
show :: Instrument -> String
$cshow :: Instrument -> String
showsPrec :: Int -> Instrument -> ShowS
$cshowsPrec :: Int -> Instrument -> ShowS
Show)

data Block = Block {
    Block -> Int
_block_length :: !Int
    , Block -> [Track]
_tracks :: [Track]
    } deriving (Block -> Block -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Block -> Block -> Bool
$c/= :: Block -> Block -> Bool
== :: Block -> Block -> Bool
$c== :: Block -> Block -> Bool
Eq, Int -> Block -> ShowS
[Block] -> ShowS
Block -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Block] -> ShowS
$cshowList :: [Block] -> ShowS
show :: Block -> String
$cshow :: Block -> String
showsPrec :: Int -> Block -> ShowS
$cshowsPrec :: Int -> Block -> ShowS
Show)

-- | Empty lines are common, so this uses IntMap as a sparse array.
type Track = IntMap Line

make_track :: [(Int, Line)] -> Track
make_track :: [(Int, Line)] -> Track
make_track = Track -> Track
carry_zeroes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [(Int, a)] -> IntMap a
IntMap.fromList

data Line = Line {
    Line -> Maybe NoteNumber
_pitch :: !(Maybe Pitch.NoteNumber)
    , Line -> Int
_instrument :: !Int
    , Line -> [Command]
_commands :: ![Command]
    } deriving (Line -> Line -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Line -> Line -> Bool
$c/= :: Line -> Line -> Bool
== :: Line -> Line -> Bool
$c== :: Line -> Line -> Bool
Eq, Int -> Line -> ShowS
[Line] -> ShowS
Line -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Line] -> ShowS
$cshowList :: [Line] -> ShowS
show :: Line -> String
$cshow :: Line -> String
showsPrec :: Int -> Line -> ShowS
$cshowsPrec :: Int -> Line -> ShowS
Show)

-- | 0 = no note
-- 1 = NN.c_1.  This is right for MIDI instruments, but not for samples.
pitch :: Int -> Maybe Pitch.NoteNumber
pitch :: Int -> Maybe NoteNumber
pitch Int
p
    | Int
p forall a. Eq a => a -> a -> Bool
== Int
0 = forall a. Maybe a
Nothing
    | Bool
otherwise = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
p forall a. Num a => a -> a -> a
- Int
1)

data Command =
    Command !Text !Word8
    | SetFrames !Int
    | Volume !Double -- ^ 0 to 1
    | VolumeSlide !Double -- ^ positive for up, negative for down
    | CutBlock
    | CutNote
    | DelayRepeat !Int !Int -- ^ delay frames, repeat each n frames
    deriving (Command -> Command -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Command -> Command -> Bool
$c/= :: Command -> Command -> Bool
== :: Command -> Command -> Bool
$c== :: Command -> Command -> Bool
Eq, Int -> Command -> ShowS
[Command] -> ShowS
Command -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Command] -> ShowS
$cshowList :: [Command] -> ShowS
show :: Command -> String
$cshow :: Command -> String
showsPrec :: Int -> Command -> ShowS
$cshowsPrec :: Int -> Command -> ShowS
Show)

commands :: [(Int, Int)] -> [Command]
commands :: [(Int, Int)] -> [Command]
commands = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a} {a}. (Integral a, Integral a) => (a, a) -> Maybe Command
make
    where
    make :: (a, a) -> Maybe Command
make (a
0, a
_) = forall a. Maybe a
Nothing
    make (a
cmd, a
val) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Word8 -> Word8 -> Command
med_command (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
cmd) (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
val)

-- | Parse a Command.
med_command :: Word8 -> Word8 -> Command
med_command :: Word8 -> Word8 -> Command
med_command Word8
cmd Word8
val = case Word8
cmd of
    Word8
0x0c -> Double -> Command
Volume forall a b. (a -> b) -> a -> b
$ forall a. Integral a => a -> Double
volume Word8
val
    Word8
0x0d
        | Word8
val forall a. Bits a => a -> a -> a
.&. Word8
0x0f forall a. Eq a => a -> a -> Bool
/= Word8
0 -> Double -> Command
VolumeSlide forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a
negate forall a b. (a -> b) -> a -> b
$ Word8 -> Double
int forall a b. (a -> b) -> a -> b
$ Word8
val forall a. Bits a => a -> a -> a
.&. Word8
0x0f
        | Bool
otherwise -> Double -> Command
VolumeSlide forall a b. (a -> b) -> a -> b
$ Word8 -> Double
int forall a b. (a -> b) -> a -> b
$ forall a. Bits a => a -> Int -> a
Bits.shiftR Word8
val Int
4 forall a. Bits a => a -> a -> a
.&. Word8
0x0f
    Word8
0x1a -> Double -> Command
VolumeSlide forall a b. (a -> b) -> a -> b
$ Word8 -> Double
int Word8
val
    Word8
0x1b -> Double -> Command
VolumeSlide forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a
negate forall a b. (a -> b) -> a -> b
$ Word8 -> Double
int Word8
val
    Word8
0x1f -> forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Command
DelayRepeat forall a b. (a -> b) -> a -> b
$ Word8 -> (Int, Int)
split4 Word8
val
    Word8
0x0f -> case Word8
val of
        Word8
0x00 -> Command
CutBlock
        Word8
0xf1 -> Text -> Word8 -> Command
Command Text
"play twice" Word8
0
        Word8
0xf2 -> Text -> Word8 -> Command
Command Text
"delay 1/2" Word8
0
        Word8
0xf3 -> Text -> Word8 -> Command
Command Text
"play thrice" Word8
0
        Word8
0xfa -> Text -> Word8 -> Command
Command Text
"pedal down" Word8
0
        Word8
0xfb -> Text -> Word8 -> Command
Command Text
"pedal up" Word8
0
        Word8
0xfe -> Text -> Word8 -> Command
Command Text
"end song" Word8
0
        Word8
0xff -> Command
CutNote
        Word8
_ -> Text -> Word8 -> Command
Command Text
"set tempo" Word8
val
    Word8
_ | Just Text
name <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word8
cmd Map Word8 Text
med_command_names -> Text -> Word8 -> Command
Command Text
name Word8
val
    Word8
_ | Bool
otherwise -> Text -> Word8 -> Command
Command (Text
"0x" forall a. Semigroup a => a -> a -> a
<> forall a. (Integral a, Show a) => Int -> a -> Text
Num.hex Int
2 Word8
cmd) Word8
val
    where
    int :: Word8 -> Double
int = forall a b. (Integral a, Num b) => a -> b
fromIntegral

med_command_names :: Map Word8 Text
med_command_names :: Map Word8 Text
med_command_names = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Word8
0x01, Text
"slide up")
    , (Word8
0x02, Text
"slide down") -- 0 uses previous value
    , (Word8
0x03, Text
"portamento") -- 0 uses previous value
    , (Word8
0x04, Text
"vibrato") -- x speed, y depth
    , (Word8
0x05, Text
"slide + fade") -- like 0d but continue slide")
    , (Word8
0x06, Text
"vibrato + fade")
    , (Word8
0x07, Text
"tremolo")
    , (Word8
0x08, Text
"hold + decay")
    , (Word8
0x09, Text
"set tempo.frames")
    , (Word8
0x0b, Text
"jump")
    , (Word8
0x0c, Text
"volume")
    , (Word8
0x0d, Text
"x crescendo, y decrescendo")
    , (Word8
0x0f, Text
"cut block, after this line")
    , (Word8
0x11, Text
"fine slide up")
    , (Word8
0x12, Text
"fine slide down")
    , (Word8
0x14, Text
"fine vibrato")
    , (Word8
0x15, Text
"set fine tune")
    , (Word8
0x16, Text
"loop")
    , (Word8
0x18, Text
"cut note at given frame")
    , (Word8
0x19, Text
"sample start offset *256 bytes")
    , (Word8
0x1a, Text
"volue up")
    , (Word8
0x1b, Text
"volume down")
    , (Word8
0x1d, Text
"jump to next block + line")
    , (Word8
0x1e, Text
"retrigger command")
    , (Word8
0x1f, Text
"xy - delay x frames, repeat every y")

    , (Word8
0x00, Text
"mod wheel")
    , (Word8
0x0e, Text
"pan")

    , (Word8
0x1f, Text
"delay")
    ]

-- | MED volume goes from 0 to 0x64 (aka 100) instead of 0 to 0x40.
volume :: Integral a => a -> Double
volume :: forall a. Integral a => a -> Double
volume = (forall a. Fractional a => a -> a -> a
/Double
0x64) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

split4 :: Word8 -> (Int, Int)
split4 :: Word8 -> (Int, Int)
split4 Word8
w = (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. Bits a => a -> Int -> a
Bits.shiftR Word8
w Int
4 forall a. Bits a => a -> a -> a
.&. Word8
0xf, forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Word8
w forall a. Bits a => a -> a -> a
.&. Word8
0xf)

-- | A Command arg of 0 is often a shorthand to carry forward the previous
-- value.  Eliminate this by doing the carry.
carry_zeroes :: Track -> Track
carry_zeroes :: Track -> Track
carry_zeroes =
    forall a. [(Int, a)] -> IntMap a
IntMap.fromAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL forall {a}.
(Int, [Command]) -> (a, Line) -> ((Int, [Command]), (a, Line))
set (Int
0, []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IntMap a -> [(Int, a)]
IntMap.toAscList
    where
    set :: (Int, [Command]) -> (a, Line) -> ((Int, [Command]), (a, Line))
set (Int
inst, [Command]
prev_cmds) (a
row, Line
line) =
        ((Line -> Int
_instrument Line
line2, [Command]
cmds), (a
row, Line
line2 { _commands :: [Command]
_commands = [Command]
cmds }))
        where
        line2 :: Line
line2 = Int -> Line -> Line
set_inst Int
inst Line
line
        cmds :: [Command]
cmds = forall a b. (a -> b) -> [a] -> [b]
map ([Command] -> Command -> Command
set_default [Command]
prev_cmds) (Line -> [Command]
_commands Line
line)
    set_default :: [Command] -> Command -> Command
set_default [Command]
prev_cmds Command
cmd =
        forall a. a -> Maybe a -> a
fromMaybe Command
cmd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip Command -> Command -> Maybe Command
carry_arg Command
cmd) [Command]
prev_cmds)
    -- If the prev_cmd was the same type, and this one has a 0, then
    -- replace with the prev_cmd.
    carry_arg :: Command -> Command -> Maybe Command
carry_arg (Command Text
c1 Word8
arg) (Command Text
c2 Word8
0) | Text
c1 forall a. Eq a => a -> a -> Bool
== Text
c2 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Word8 -> Command
Command Text
c1 Word8
arg
    carry_arg (VolumeSlide Double
arg) (VolumeSlide Double
0) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Double -> Command
VolumeSlide Double
arg
    carry_arg Command
_ Command
_ = forall a. Maybe a
Nothing
    set_inst :: Int -> Line -> Line
set_inst Int
inst Line
line
        | Line -> Int
_instrument Line
line forall a. Eq a => a -> a -> Bool
== Int
0 = Line
line { _instrument :: Int
_instrument = Int
inst }
        | Bool
otherwise = Line
line

-- * transform

map_instruments :: Map Text Text -> Module -> Module
map_instruments :: Map Text Text -> Module -> Module
map_instruments Map Text Text
inst_map Module
mod = Module
mod { _instruments :: IntMap Instrument
_instruments = Instrument -> Instrument
set forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module -> IntMap Instrument
_instruments Module
mod }
    where
    set :: Instrument -> Instrument
set Instrument
inst = Instrument
inst
        { _instrument_name :: Instrument
_instrument_name =
            Text -> Instrument
ScoreT.Instrument forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Text
inst_name Text
inst_name Map Text Text
inst_map
        } where inst_name :: Text
inst_name = Instrument -> Text
ScoreT.instrument_name forall a b. (a -> b) -> a -> b
$ Instrument -> Instrument
_instrument_name Instrument
inst

transpose_instruments :: Map ScoreT.Instrument Pitch.NoteNumber
    -> Module -> Module
transpose_instruments :: Map Instrument NoteNumber -> Module -> Module
transpose_instruments Map Instrument NoteNumber
transpose Module
mod = forall a b c. (a -> b -> c) -> b -> a -> c
flip (Line -> Line) -> Module -> Module
modify_lines Module
mod forall a b. (a -> b) -> a -> b
$ \Line
line ->
    case (Line -> Maybe NoteNumber
_pitch Line
line, forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Line -> Int
_instrument Line
line) Map Int NoteNumber
by_num) of
        (Just NoteNumber
nn, Just NoteNumber
steps) -> Line
line { _pitch :: Maybe NoteNumber
_pitch = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ NoteNumber
nn forall a. Num a => a -> a -> a
+ NoteNumber
steps }
        (Maybe NoteNumber, Maybe NoteNumber)
_ -> Line
line
    where
    by_num :: Map Int NoteNumber
by_num = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a a2 b. (a -> Maybe a2) -> [(a, b)] -> [(a2, b)]
Lists.mapMaybeFst (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map Instrument Int
inst_to_num) forall a b. (a -> b) -> a -> b
$
        forall k a. Map k a -> [(k, a)]
Map.toList Map Instrument NoteNumber
transpose
    inst_to_num :: Map Instrument Int
inst_to_num = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (Instrument -> Instrument
_instrument_name Instrument
inst, Int
n)
        | (Int
n, Instrument
inst) <- forall a. IntMap a -> [(Int, a)]
IntMap.toList (Module -> IntMap Instrument
_instruments Module
mod)
        ]

modify_lines :: (Line -> Line) -> Module -> Module
modify_lines :: (Line -> Line) -> Module -> Module
modify_lines Line -> Line
f = (Track -> Track) -> Module -> Module
modify_tracks (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Line -> Line
f)

modify_tracks :: (Track -> Track) -> Module -> Module
modify_tracks :: (Track -> Track) -> Module -> Module
modify_tracks Track -> Track
f Module
mod = Module
mod { _blocks :: [Block]
_blocks = forall a b. (a -> b) -> [a] -> [b]
map Block -> Block
tracks (Module -> [Block]
_blocks Module
mod) }
    where tracks :: Block -> Block
tracks Block
block = Block
block { _tracks :: [Track]
_tracks = forall a b. (a -> b) -> [a] -> [b]
map Track -> Track
f (Block -> [Track]
_tracks Block
block) }