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

-- | Simulate the state of a MIDI synthesizer.
--
-- "Midi.Synth" is different in that it wants to convert MIDI messages to
-- higher level notes, but similar in that it's also simulating a synthesizer.
-- This module focuses on the instantaneous state of the synth.
module Midi.State (
    State(..), empty, Channel(..), get_channel, empty_channel
    , Control(..), Addr
    , Message, convert
    , play, process, diff
) where
import qualified Data.Map.Strict as Map
import qualified Data.Maybe as Maybe

import qualified Util.Maps as Maps
import qualified Util.Pretty as Pretty
import qualified Util.Lists as Lists

import qualified Midi.Midi as Midi
import Global


newtype State = State (Map Addr Channel)
    deriving (State -> State -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: State -> State -> Bool
$c/= :: State -> State -> Bool
== :: State -> State -> Bool
$c== :: State -> State -> Bool
Eq, Int -> State -> ShowS
[State] -> ShowS
State -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [State] -> ShowS
$cshowList :: [State] -> ShowS
show :: State -> String
$cshow :: State -> String
showsPrec :: Int -> State -> ShowS
$cshowsPrec :: Int -> State -> ShowS
Show, [State] -> Doc
State -> Text
State -> Doc
forall a. (a -> Text) -> (a -> Doc) -> ([a] -> Doc) -> Pretty a
formatList :: [State] -> Doc
$cformatList :: [State] -> Doc
format :: State -> Doc
$cformat :: State -> Doc
pretty :: State -> Text
$cpretty :: State -> Text
Pretty)

empty :: State
empty :: State
empty = Map Addr Channel -> State
State forall k a. Map k a
Map.empty

data Channel = Channel {
    Channel -> Map Key Velocity
chan_notes :: !(Map Midi.Key Midi.Velocity)
    , Channel -> PitchBendValue
chan_pb :: !Midi.PitchBendValue
    , Channel -> Map Control Velocity
chan_controls :: !(Map Control Midi.ControlValue)
    } deriving (Channel -> Channel -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Channel -> Channel -> Bool
$c/= :: Channel -> Channel -> Bool
== :: Channel -> Channel -> Bool
$c== :: Channel -> Channel -> Bool
Eq, Int -> Channel -> ShowS
[Channel] -> ShowS
Channel -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Channel] -> ShowS
$cshowList :: [Channel] -> ShowS
show :: Channel -> String
$cshow :: Channel -> String
showsPrec :: Int -> Channel -> ShowS
$cshowsPrec :: Int -> Channel -> ShowS
Show)

empty_channel :: Channel
empty_channel :: Channel
empty_channel = Map Key Velocity
-> PitchBendValue -> Map Control Velocity -> Channel
Channel forall k a. Map k a
Map.empty PitchBendValue
0 forall k a. Map k a
Map.empty

get_channel :: Addr -> State -> Channel
get_channel :: Addr -> State -> Channel
get_channel Addr
addr (State Map Addr Channel
chans) = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Channel
empty_channel Addr
addr Map Addr Channel
chans

instance Pretty Channel where
    format :: Channel -> Doc
format (Channel Map Key Velocity
notes PitchBendValue
pb Map Control Velocity
controls) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"Channel"
        [ (Text
"notes", forall a. Pretty a => a -> Doc
Pretty.format Map Key Velocity
notes)
        , (Text
"pb", forall a. Pretty a => a -> Doc
Pretty.format PitchBendValue
pb)
        , (Text
"controls", forall a. Pretty a => a -> Doc
Pretty.format Map Control Velocity
controls)
        ]

data Control = CC Midi.Control | Aftertouch Midi.Key | Pressure
    deriving (Control -> Control -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Control -> Control -> Bool
$c/= :: Control -> Control -> Bool
== :: Control -> Control -> Bool
$c== :: Control -> Control -> Bool
Eq, Eq Control
Control -> Control -> Bool
Control -> Control -> Ordering
Control -> Control -> Control
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Control -> Control -> Control
$cmin :: Control -> Control -> Control
max :: Control -> Control -> Control
$cmax :: Control -> Control -> Control
>= :: Control -> Control -> Bool
$c>= :: Control -> Control -> Bool
> :: Control -> Control -> Bool
$c> :: Control -> Control -> Bool
<= :: Control -> Control -> Bool
$c<= :: Control -> Control -> Bool
< :: Control -> Control -> Bool
$c< :: Control -> Control -> Bool
compare :: Control -> Control -> Ordering
$ccompare :: Control -> Control -> Ordering
Ord, Int -> Control -> ShowS
[Control] -> ShowS
Control -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Control] -> ShowS
$cshowList :: [Control] -> ShowS
show :: Control -> String
$cshow :: Control -> String
showsPrec :: Int -> Control -> ShowS
$cshowsPrec :: Int -> Control -> ShowS
Show)
type Addr = (Midi.WriteDevice, Midi.Channel)
type Message = (Midi.WriteDevice, Midi.Message)

instance Pretty Control where
    pretty :: Control -> Text
pretty (CC Velocity
cc) = forall a. Pretty a => a -> Text
pretty Velocity
cc
    pretty (Aftertouch Key
key) = Text
"at:" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Key
key
    pretty Control
Pressure = Text
"pressure"

cc_msg :: Control -> Midi.ControlValue -> Midi.ChannelMessage
cc_msg :: Control -> Velocity -> ChannelMessage
cc_msg (CC Velocity
cc) Velocity
val = Velocity -> Velocity -> ChannelMessage
Midi.ControlChange Velocity
cc Velocity
val
cc_msg (Aftertouch Key
key) Velocity
val = Key -> Velocity -> ChannelMessage
Midi.Aftertouch Key
key Velocity
val
cc_msg Control
Pressure Velocity
val = Velocity -> ChannelMessage
Midi.ChannelPressure Velocity
val

convert :: Midi.WriteMessage -> Message
convert :: WriteMessage -> Message
convert WriteMessage
msg = (WriteMessage -> WriteDevice
Midi.wmsg_dev WriteMessage
msg, WriteMessage -> Message
Midi.wmsg_msg WriteMessage
msg)

-- * play

play :: [Message] -> State -> State
play :: [Message] -> State -> State
play [Message]
msgs State
state = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' State -> Message -> State
process State
state [Message]
msgs

process :: State -> Message -> State
process :: State -> Message -> State
process State
state (WriteDevice
dev, Midi.ChannelMessage Velocity
chan ChannelMessage
msg) = case ChannelMessage
msg of
    Midi.NoteOff Key
key Velocity
_ -> (Map Key Velocity -> Map Key Velocity) -> State
notes (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Key
key)
    Midi.NoteOn Key
key Velocity
vel
        | Velocity
vel forall a. Eq a => a -> a -> Bool
== Velocity
0 -> (Map Key Velocity -> Map Key Velocity) -> State
notes (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Key
key)
        | Bool
otherwise -> (Map Key Velocity -> Map Key Velocity) -> State
notes (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Key
key Velocity
vel)
    Midi.Aftertouch Key
key Velocity
val -> (Map Control Velocity -> Map Control Velocity) -> State
controls (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Key -> Control
Aftertouch Key
key) Velocity
val)
    Midi.ControlChange Velocity
cc Velocity
val -> (Map Control Velocity -> Map Control Velocity) -> State
controls (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Velocity -> Control
CC Velocity
cc) Velocity
val)
    Midi.ProgramChange Velocity
_pgm -> State
state -- I don't track current patch
    Midi.ChannelPressure Velocity
val -> (Map Control Velocity -> Map Control Velocity) -> State
controls (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Control
Pressure Velocity
val)
    Midi.PitchBend PitchBendValue
val -> (Channel -> Channel) -> State
modify forall a b. (a -> b) -> a -> b
$ \Channel
chan -> Channel
chan { chan_pb :: PitchBendValue
chan_pb = PitchBendValue
val }
    ChannelMessage
Midi.AllSoundOff -> (Map Key Velocity -> Map Key Velocity) -> State
notes (forall a b. a -> b -> a
const forall k a. Map k a
Map.empty)
    ChannelMessage
Midi.ResetAllControls -> (Map Control Velocity -> Map Control Velocity) -> State
controls (forall a b. a -> b -> a
const forall k a. Map k a
Map.empty)
    ChannelMessage
Midi.AllNotesOff -> (Map Key Velocity -> Map Key Velocity) -> State
notes (forall a b. a -> b -> a
const forall k a. Map k a
Map.empty)
    ChannelMessage
_ -> State
state
    where
    notes :: (Map Key Velocity -> Map Key Velocity) -> State
notes Map Key Velocity -> Map Key Velocity
f = (Channel -> Channel) -> State
modify forall a b. (a -> b) -> a -> b
$ \Channel
chan -> Channel
chan { chan_notes :: Map Key Velocity
chan_notes = Map Key Velocity -> Map Key Velocity
f (Channel -> Map Key Velocity
chan_notes Channel
chan) }
    controls :: (Map Control Velocity -> Map Control Velocity) -> State
controls Map Control Velocity -> Map Control Velocity
f = (Channel -> Channel) -> State
modify forall a b. (a -> b) -> a -> b
$ \Channel
chan ->
        Channel
chan { chan_controls :: Map Control Velocity
chan_controls = Map Control Velocity -> Map Control Velocity
f (Channel -> Map Control Velocity
chan_controls Channel
chan) }
    modify :: (Channel -> Channel) -> State
modify = State -> Addr -> (Channel -> Channel) -> State
modify_addr State
state (WriteDevice
dev, Velocity
chan)
process State
state Message
_ = State
state

modify_addr :: State -> Addr -> (Channel -> Channel) -> State
modify_addr :: State -> Addr -> (Channel -> Channel) -> State
modify_addr (State Map Addr Channel
chans) Addr
addr Channel -> Channel
f =
    Map Addr Channel -> State
State (forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Channel -> Channel
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
Maybe.fromMaybe Channel
empty_channel) Addr
addr Map Addr Channel
chans)


-- * diff

-- | Emit msgs needed to take one State to another.
diff :: State -> State -> [Message]
diff :: State -> State -> [Message]
diff (State Map Addr Channel
chans1) (State Map Addr Channel
chans2) =
    forall k a b.
Ord k =>
Map k a -> Map k a -> a -> (k -> a -> a -> [b]) -> [b]
diff_map Map Addr Channel
chans1 Map Addr Channel
chans2 Channel
empty_channel Addr -> Channel -> Channel -> [Message]
diff_chan

diff_chan :: Addr -> Channel -> Channel -> [Message]
diff_chan :: Addr -> Channel -> Channel -> [Message]
diff_chan (WriteDevice
dev, Velocity
chan) (Channel Map Key Velocity
notes1 PitchBendValue
pb1 Map Control Velocity
controls1)
        (Channel Map Key Velocity
notes2 PitchBendValue
pb2 Map Control Velocity
controls2) =
    forall a b. (a -> b) -> [a] -> [b]
map (\ChannelMessage
m -> (WriteDevice
dev, Velocity -> ChannelMessage -> Message
Midi.ChannelMessage Velocity
chan ChannelMessage
m)) forall a b. (a -> b) -> a -> b
$
    (if PitchBendValue
pb1 forall a. Eq a => a -> a -> Bool
== PitchBendValue
pb2 then [] else [PitchBendValue -> ChannelMessage
Midi.PitchBend PitchBendValue
pb2])
    forall a. [a] -> [a] -> [a]
++ forall k a b.
Ord k =>
Map k a -> Map k a -> a -> (k -> a -> a -> [b]) -> [b]
diff_map Map Control Velocity
controls1 Map Control Velocity
controls2 Velocity
0 Control -> Velocity -> Velocity -> [ChannelMessage]
diff_control
    forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key -> Paired Velocity Velocity -> [ChannelMessage]
diff_note) (forall k v1 v2.
Ord k =>
Map k v1 -> Map k v2 -> [(k, Paired v1 v2)]
Maps.pairs Map Key Velocity
notes1 Map Key Velocity
notes2)

diff_control :: Control -> Midi.ControlValue -> Midi.ControlValue
    -> [Midi.ChannelMessage]
diff_control :: Control -> Velocity -> Velocity -> [ChannelMessage]
diff_control Control
control Velocity
v1 Velocity
v2
    | Velocity
v1 forall a. Eq a => a -> a -> Bool
== Velocity
v2 = []
    | Bool
otherwise = [Control -> Velocity -> ChannelMessage
cc_msg Control
control Velocity
v2]

diff_note :: Midi.Key -> Lists.Paired Midi.Velocity Midi.Velocity
    -> [Midi.ChannelMessage]
diff_note :: Key -> Paired Velocity Velocity -> [ChannelMessage]
diff_note Key
key (Lists.First Velocity
_) = [Key -> Velocity -> ChannelMessage
Midi.NoteOff Key
key Velocity
0]
diff_note Key
key (Lists.Second Velocity
vel) = [Key -> Velocity -> ChannelMessage
Midi.NoteOn Key
key Velocity
vel]
diff_note Key
key (Lists.Both Velocity
v1 Velocity
v2)
    | Velocity
v1 forall a. Eq a => a -> a -> Bool
== Velocity
v2 = []
    | Bool
otherwise = [Key -> Velocity -> ChannelMessage
Midi.NoteOff Key
key Velocity
0, Key -> Velocity -> ChannelMessage
Midi.NoteOn Key
key Velocity
v2]

diff_map :: Ord k => Map k a -> Map k a -> a -> (k -> a -> a -> [b]) -> [b]
diff_map :: forall k a b.
Ord k =>
Map k a -> Map k a -> a -> (k -> a -> a -> [b]) -> [b]
diff_map Map k a
m1 Map k a
m2 a
deflt k -> a -> a -> [b]
f = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (k, Paired a a) -> [b]
go (forall k v1 v2.
Ord k =>
Map k v1 -> Map k v2 -> [(k, Paired v1 v2)]
Maps.pairs Map k a
m1 Map k a
m2)
    where
    go :: (k, Paired a a) -> [b]
go (k
k, Lists.Both a
v1 a
v2) = k -> a -> a -> [b]
f k
k a
v1 a
v2
    go (k
k, Lists.First a
v1) = k -> a -> a -> [b]
f k
k a
v1 a
deflt
    go (k
k, Lists.Second a
v2) = k -> a -> a -> [b]
f k
k a
deflt a
v2