-- 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.Seq as Seq

import qualified Midi.Midi as Midi
import Global


newtype State = State (Map Addr Channel) deriving (State -> State -> Bool
(State -> State -> Bool) -> (State -> State -> Bool) -> Eq State
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
(Int -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
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
(State -> Text)
-> (State -> Doc) -> ([State] -> Doc) -> Pretty State
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 Map Addr Channel
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
(Channel -> Channel -> Bool)
-> (Channel -> Channel -> Bool) -> Eq Channel
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
(Int -> Channel -> ShowS)
-> (Channel -> String) -> ([Channel] -> ShowS) -> Show Channel
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 Map Key Velocity
forall k a. Map k a
Map.empty PitchBendValue
0 Map Control Velocity
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) = Channel -> Addr -> Map Addr Channel -> Channel
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", Map Key Velocity -> Doc
forall a. Pretty a => a -> Doc
Pretty.format Map Key Velocity
notes)
        , (Text
"pb", PitchBendValue -> Doc
forall a. Pretty a => a -> Doc
Pretty.format PitchBendValue
pb)
        , (Text
"controls", Map Control Velocity -> Doc
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
(Control -> Control -> Bool)
-> (Control -> Control -> Bool) -> Eq Control
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
Eq Control
-> (Control -> Control -> Ordering)
-> (Control -> Control -> Bool)
-> (Control -> Control -> Bool)
-> (Control -> Control -> Bool)
-> (Control -> Control -> Bool)
-> (Control -> Control -> Control)
-> (Control -> Control -> Control)
-> Ord 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
(Int -> Control -> ShowS)
-> (Control -> String) -> ([Control] -> ShowS) -> Show Control
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) = Velocity -> Text
forall a. Pretty a => a -> Text
pretty Velocity
cc
    pretty (Aftertouch Key
key) = Text
"at:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Key -> Text
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 = (State -> Message -> State) -> State -> [Message] -> 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 (Key -> Map Key Velocity -> Map Key Velocity
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Key
key)
    Midi.NoteOn Key
key Velocity
vel
        | Velocity
vel Velocity -> Velocity -> Bool
forall a. Eq a => a -> a -> Bool
== Velocity
0 -> (Map Key Velocity -> Map Key Velocity) -> State
notes (Key -> Map Key Velocity -> Map Key Velocity
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 (Key -> Velocity -> Map Key Velocity -> Map Key Velocity
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 (Control -> Velocity -> Map Control Velocity -> Map Control Velocity
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 (Control -> Velocity -> Map Control Velocity -> Map Control Velocity
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 (Control -> Velocity -> Map Control Velocity -> Map Control Velocity
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 ((Channel -> Channel) -> State) -> (Channel -> Channel) -> State
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 (Map Key Velocity -> Map Key Velocity -> Map Key Velocity
forall a b. a -> b -> a
const Map Key Velocity
forall k a. Map k a
Map.empty)
    ChannelMessage
Midi.ResetAllControls -> (Map Control Velocity -> Map Control Velocity) -> State
controls (Map Control Velocity
-> Map Control Velocity -> Map Control Velocity
forall a b. a -> b -> a
const Map Control Velocity
forall k a. Map k a
Map.empty)
    ChannelMessage
Midi.AllNotesOff -> (Map Key Velocity -> Map Key Velocity) -> State
notes (Map Key Velocity -> Map Key Velocity -> Map Key Velocity
forall a b. a -> b -> a
const Map Key Velocity
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 ((Channel -> Channel) -> State) -> (Channel -> Channel) -> State
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 ((Channel -> Channel) -> State) -> (Channel -> Channel) -> State
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 ((Maybe Channel -> Maybe Channel)
-> Addr -> Map Addr Channel -> Map Addr Channel
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Channel -> Maybe Channel
forall a. a -> Maybe a
Just (Channel -> Maybe Channel)
-> (Maybe Channel -> Channel) -> Maybe Channel -> Maybe Channel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Channel -> Channel
f (Channel -> Channel)
-> (Maybe Channel -> Channel) -> Maybe Channel -> Channel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Channel -> Maybe Channel -> Channel
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) =
    Map Addr Channel
-> Map Addr Channel
-> Channel
-> (Addr -> Channel -> Channel -> [Message])
-> [Message]
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) =
    (ChannelMessage -> Message) -> [ChannelMessage] -> [Message]
forall a b. (a -> b) -> [a] -> [b]
map (\ChannelMessage
m -> (WriteDevice
dev, Velocity -> ChannelMessage -> Message
Midi.ChannelMessage Velocity
chan ChannelMessage
m)) ([ChannelMessage] -> [Message]) -> [ChannelMessage] -> [Message]
forall a b. (a -> b) -> a -> b
$
    (if PitchBendValue
pb1 PitchBendValue -> PitchBendValue -> Bool
forall a. Eq a => a -> a -> Bool
== PitchBendValue
pb2 then [] else [PitchBendValue -> ChannelMessage
Midi.PitchBend PitchBendValue
pb2])
    [ChannelMessage] -> [ChannelMessage] -> [ChannelMessage]
forall a. [a] -> [a] -> [a]
++ Map Control Velocity
-> Map Control Velocity
-> Velocity
-> (Control -> Velocity -> Velocity -> [ChannelMessage])
-> [ChannelMessage]
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
    [ChannelMessage] -> [ChannelMessage] -> [ChannelMessage]
forall a. [a] -> [a] -> [a]
++ ((Key, Paired Velocity Velocity) -> [ChannelMessage])
-> [(Key, Paired Velocity Velocity)] -> [ChannelMessage]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Key -> Paired Velocity Velocity -> [ChannelMessage])
-> (Key, Paired Velocity Velocity) -> [ChannelMessage]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key -> Paired Velocity Velocity -> [ChannelMessage]
diff_note) (Map Key Velocity
-> Map Key Velocity -> [(Key, Paired Velocity Velocity)]
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 Velocity -> Velocity -> Bool
forall a. Eq a => a -> a -> Bool
== Velocity
v2 = []
    | Bool
otherwise = [Control -> Velocity -> ChannelMessage
cc_msg Control
control Velocity
v2]

diff_note :: Midi.Key -> Seq.Paired Midi.Velocity Midi.Velocity
    -> [Midi.ChannelMessage]
diff_note :: Key -> Paired Velocity Velocity -> [ChannelMessage]
diff_note Key
key (Seq.First Velocity
_) = [Key -> Velocity -> ChannelMessage
Midi.NoteOff Key
key Velocity
0]
diff_note Key
key (Seq.Second Velocity
vel) = [Key -> Velocity -> ChannelMessage
Midi.NoteOn Key
key Velocity
vel]
diff_note Key
key (Seq.Both Velocity
v1 Velocity
v2)
    | Velocity
v1 Velocity -> Velocity -> Bool
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 = ((k, Paired a a) -> [b]) -> [(k, Paired a a)] -> [b]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (k, Paired a a) -> [b]
go (Map k a -> Map k a -> [(k, Paired a a)]
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, Seq.Both a
v1 a
v2) = k -> a -> a -> [b]
f k
k a
v1 a
v2
    go (k
k, Seq.First a
v1) = k -> a -> a -> [b]
f k
k a
v1 a
deflt
    go (k
k, Seq.Second a
v2) = k -> a -> a -> [b]
f k
k a
deflt a
v2