-- 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 a MIDI synth and turn low level MIDI msgs back into a medium
-- level form.  This is a bit like \"unperform\".
module Midi.Synth where
import qualified Control.Monad.Identity as Identity
import qualified Control.Monad.Reader as Reader
import qualified Control.Monad.State.Strict as State

import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import qualified Data.Tuple as Tuple

import qualified Util.Num as Num
import qualified Util.Lists as Lists
import qualified Midi.Midi as Midi
import qualified Midi.State as MState
import           Midi.State (Addr)

import qualified Perform.Pitch as Pitch
import qualified Perform.RealTime as RealTime

import           Global
import           Types


-- * analyze

initial_pitches :: [Note] -> [(Int, Pitch.NoteNumber)]
initial_pitches :: [Note] -> [(Int, NoteNumber)]
initial_pitches [Note]
notes = forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> (b, a)
Tuple.swap forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. Num a => a -> a -> a
(+) [(Note -> NoteNumber
initial_pitch Note
note, Int
1) | Note
note <- [Note]
notes ]

nonconstant_pitches :: [Note] -> [Note]
nonconstant_pitches :: [Note] -> [Note]
nonconstant_pitches = forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall end. NoteT end -> [(RealTime, NoteNumber)]
note_pitches
    -- filter out ones after note-off
    -- take a decay time

initial_pitch :: Note -> Pitch.NoteNumber
initial_pitch :: Note -> NoteNumber
initial_pitch = NoteNumber -> NoteNumber
round_cents forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall end. NoteT end -> NoteNumber
note_pitch

round_cents :: Pitch.NoteNumber -> Pitch.NoteNumber
round_cents :: NoteNumber -> NoteNumber
round_cents = (forall a. Fractional a => a -> a -> a
/NoteNumber
100) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> NoteNumber
Pitch.nn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
*NoteNumber
100)

-- * compute

data State = State {
    -- constant
    State -> Map Addr PbRange
state_pb_range :: !(Map Addr PbRange)

    , State -> State
state_channel :: !MState.State
    -- | Notes still sounding.  This retains notes for 'deactivate_time' after
    -- their note-off to capture controls during the decay.
    , State -> Map Addr [SoundingNote]
state_active :: !(Map Addr [SoundingNote])
    , State -> [Note]
state_notes :: ![Note]
    , State -> [(WriteMessage, Text)]
state_warns :: ![(Midi.WriteMessage, Text)]
    } deriving (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)

empty_state :: State
empty_state :: State
empty_state = State
    { state_pb_range :: Map Addr PbRange
state_pb_range = forall a. Monoid a => a
mempty
    , state_channel :: State
state_channel = State
MState.empty
    , state_active :: Map Addr [SoundingNote]
state_active = forall a. Monoid a => a
mempty
    , state_notes :: [Note]
state_notes = []
    , state_warns :: [(WriteMessage, Text)]
state_warns = []
    }

-- | (down, up)
type PbRange = (Pitch.NoteNumber, Pitch.NoteNumber)

get_pb_range :: Addr -> State -> PbRange
get_pb_range :: Addr -> State -> PbRange
get_pb_range Addr
addr = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (-NoteNumber
2, NoteNumber
2) Addr
addr forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map Addr PbRange
state_pb_range
    -- This (-2, 2) thing is probably wrong, maybe I should crash.

-- | SoundingNotes may still be open.
type SoundingNote = NoteT (Maybe RealTime)
type Note = NoteT RealTime

data NoteT end = Note {
    forall end. NoteT end -> RealTime
note_start :: RealTime
    , forall end. NoteT end -> end
note_end :: end
    , forall end. NoteT end -> Key
note_key :: Midi.Key
    , forall end. NoteT end -> Channel
note_vel :: Midi.Velocity
    , forall end. NoteT end -> NoteNumber
note_pitch :: Pitch.NoteNumber
    , forall end. NoteT end -> [(RealTime, NoteNumber)]
note_pitches :: [(RealTime, Pitch.NoteNumber)]
    , forall end. NoteT end -> ControlMap
note_controls :: ControlMap
    , forall end. NoteT end -> Addr
note_addr :: Addr
    } deriving (NoteT end -> NoteT end -> Bool
forall end. Eq end => NoteT end -> NoteT end -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoteT end -> NoteT end -> Bool
$c/= :: forall end. Eq end => NoteT end -> NoteT end -> Bool
== :: NoteT end -> NoteT end -> Bool
$c== :: forall end. Eq end => NoteT end -> NoteT end -> Bool
Eq, Int -> NoteT end -> ShowS
forall end. Show end => Int -> NoteT end -> ShowS
forall end. Show end => [NoteT end] -> ShowS
forall end. Show end => NoteT end -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoteT end] -> ShowS
$cshowList :: forall end. Show end => [NoteT end] -> ShowS
show :: NoteT end -> String
$cshow :: forall end. Show end => NoteT end -> String
showsPrec :: Int -> NoteT end -> ShowS
$cshowsPrec :: forall end. Show end => Int -> NoteT end -> ShowS
Show)

type ControlMap = Map MState.Control [(RealTime, Midi.ControlValue)]

-- | Keep the current msg for 'warn'.
type SynthM a = Reader.ReaderT Midi.WriteMessage
    (State.StateT State Identity.Identity) a

modify :: (State -> State) -> SynthM ()
modify :: (State -> State) -> SynthM ()
modify State -> State
f = do
    State
st <- forall s (m :: * -> *). MonadState s m => m s
State.get
    forall s (m :: * -> *). MonadState s m => s -> m ()
State.put forall a b. (a -> b) -> a -> b
$! State -> State
f State
st

run :: State -> [Midi.WriteMessage] -> State
run :: State -> [WriteMessage] -> State
run State
state [WriteMessage]
msgs = State -> State
postproc forall a b. (a -> b) -> a -> b
$ forall {a}. StateT State Identity a -> State
run_state (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe WriteMessage, WriteMessage) -> StateT State Identity ()
msg1 (forall a. [a] -> [(Maybe a, a)]
Lists.zipPrev [WriteMessage]
msgs))
    where
    run_state :: StateT State Identity a -> State
run_state = forall a. Identity a -> a
Identity.runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
State.execStateT State
state
    msg1 :: (Maybe WriteMessage, WriteMessage) -> StateT State Identity ()
msg1 (Maybe WriteMessage
prev, WriteMessage
wmsg) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
Reader.runReaderT WriteMessage
wmsg forall a b. (a -> b) -> a -> b
$ do
        let prev_t :: RealTime
prev_t = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (-RealTime
RealTime.larger) WriteMessage -> RealTime
Midi.wmsg_ts Maybe WriteMessage
prev
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WriteMessage -> RealTime
Midi.wmsg_ts WriteMessage
wmsg forall a. Ord a => a -> a -> Bool
< RealTime
prev_t) forall a b. (a -> b) -> a -> b
$
            Text -> SynthM ()
warn forall a b. (a -> b) -> a -> b
$ Text
"timestamp less than previous: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty RealTime
prev_t
        WriteMessage -> SynthM ()
run_msg WriteMessage
wmsg

postproc :: State -> State
postproc :: State -> State
postproc State
state_ = State
state
    { state_active :: Map Addr [SoundingNote]
state_active = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\Addr
_ [SoundingNote]
ns -> Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SoundingNote]
ns)) forall a b. (a -> b) -> a -> b
$
        forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall a b. (a -> b) -> [a] -> [b]
map forall {end}. NoteT end -> NoteT end
postproc_note) (State -> Map Addr [SoundingNote]
state_active State
state)
    , state_notes :: [Note]
state_notes = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {end}. NoteT end -> NoteT end
postproc_note (State -> [Note]
state_notes State
state)
    , state_warns :: [(WriteMessage, Text)]
state_warns = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ State -> [(WriteMessage, Text)]
state_warns State
state
    }
    where
    state :: State
state = RealTime -> State -> State
deactivate RealTime
9999999 State
state_
    postproc_note :: NoteT end -> NoteT end
postproc_note NoteT end
note = NoteT end
note
        { note_controls :: ControlMap
note_controls = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall a. [a] -> [a]
reverse (forall end. NoteT end -> ControlMap
note_controls NoteT end
note)
        , note_pitches :: [(RealTime, NoteNumber)]
note_pitches = forall a. [a] -> [a]
reverse (forall end. NoteT end -> [(RealTime, NoteNumber)]
note_pitches NoteT end
note)
        }

run_msg :: Midi.WriteMessage -> SynthM ()
run_msg :: WriteMessage -> SynthM ()
run_msg wmsg :: WriteMessage
wmsg@(Midi.WriteMessage WriteDevice
dev RealTime
ts (Midi.ChannelMessage Channel
chan ChannelMessage
msg)) = do
    let addr :: Addr
addr = (WriteDevice
dev, Channel
chan)
    (State -> State) -> SynthM ()
modify forall a b. (a -> b) -> a -> b
$ WriteMessage -> State -> State
update_channel_state WriteMessage
wmsg forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealTime -> State -> State
deactivate RealTime
ts
    case ChannelMessage -> ChannelMessage
normalize_msg ChannelMessage
msg of
        Midi.NoteOff Key
key Channel
_ -> Addr -> RealTime -> Key -> SynthM ()
note_off Addr
addr RealTime
ts Key
key
        Midi.NoteOn Key
key Channel
vel -> Addr -> RealTime -> Key -> Channel -> SynthM ()
note_on Addr
addr RealTime
ts Key
key Channel
vel
        Midi.Aftertouch Key
_ Channel
_ -> Text -> SynthM ()
warn Text
"aftertouch not supported"
        Midi.ControlChange Channel
c Channel
val -> Addr -> RealTime -> Control -> Channel -> SynthM ()
control Addr
addr RealTime
ts (Channel -> Control
MState.CC Channel
c) Channel
val
        Midi.ProgramChange Channel
_ -> Text -> SynthM ()
warn Text
"program change not supported"
        Midi.ChannelPressure Channel
val -> Addr -> RealTime -> Control -> Channel -> SynthM ()
control Addr
addr RealTime
ts Control
MState.Pressure Channel
val
        Midi.PitchBend PitchBendValue
val -> Addr -> RealTime -> PitchBendValue -> SynthM ()
pitch_bend Addr
addr RealTime
ts PitchBendValue
val
        ChannelMessage
_ -> Text -> SynthM ()
warn Text
"unhandled msg"
run_msg WriteMessage
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

update_channel_state :: Midi.WriteMessage -> State -> State
update_channel_state :: WriteMessage -> State -> State
update_channel_state WriteMessage
wmsg State
state =
    State
state { state_channel :: State
state_channel = State -> Message -> State
MState.process (State -> State
state_channel State
state) Message
msg }
    where msg :: Message
msg = (WriteMessage -> WriteDevice
Midi.wmsg_dev WriteMessage
wmsg, WriteMessage -> Message
Midi.wmsg_msg WriteMessage
wmsg)

normalize_msg :: Midi.ChannelMessage -> Midi.ChannelMessage
normalize_msg :: ChannelMessage -> ChannelMessage
normalize_msg (Midi.NoteOn Key
key Channel
0) = Key -> Channel -> ChannelMessage
Midi.NoteOff Key
key Channel
1
normalize_msg ChannelMessage
msg = ChannelMessage
msg

-- | After notes have had a note-off time for a certain amount of time, move
-- them from 'state_active' to 'state_notes'.  The certain amount of time
-- should be the note's decay time, but since I don't really know that, just
-- pick an arbitrary constant.
deactivate :: RealTime -> State -> State
deactivate :: RealTime -> State -> State
deactivate RealTime
now State
state = State
state
    { state_active :: Map Addr [SoundingNote]
state_active = Map Addr [SoundingNote]
still_active
    , state_notes :: [Note]
state_notes = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {end}. NoteT (Maybe end) -> Maybe (NoteT end)
close (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[SoundingNote]]
done) forall a. [a] -> [a] -> [a]
++ State -> [Note]
state_notes State
state
    }
    where
    ([Addr]
addrs, ([[SoundingNote]]
done, [[SoundingNote]]
active)) = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition SoundingNote -> Bool
note_done)) forall a b. (a -> b) -> a -> b
$
        forall k a. Map k a -> [(k, a)]
Map.toList (State -> Map Addr [SoundingNote]
state_active State
state)
    still_active :: Map Addr [SoundingNote]
still_active = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Addr]
addrs [[SoundingNote]]
active
    note_done :: SoundingNote -> Bool
note_done SoundingNote
note = case forall end. NoteT end -> end
note_end SoundingNote
note of
        Just RealTime
d -> RealTime
now forall a. Ord a => a -> a -> Bool
>= RealTime
d forall a. Num a => a -> a -> a
+ RealTime
deactivate_time
        Maybe RealTime
Nothing -> Bool
False
    close :: NoteT (Maybe end) -> Maybe (NoteT end)
close NoteT (Maybe end)
note = case forall end. NoteT end -> end
note_end NoteT (Maybe end)
note of
        Maybe end
Nothing -> forall a. Maybe a
Nothing
        Just end
d -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ NoteT (Maybe end)
note { note_end :: end
note_end = end
d }

deactivate_time :: RealTime
deactivate_time :: RealTime
deactivate_time = RealTime
1

-- * msgs

note_on :: Addr -> RealTime -> Midi.Key -> Midi.Velocity -> SynthM ()
note_on :: Addr -> RealTime -> Key -> Channel -> SynthM ()
note_on Addr
addr RealTime
ts Key
key Channel
vel = do
    [SoundingNote]
active <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Addr
addr forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map Addr [SoundingNote]
state_active
    let sounding :: [SoundingNote]
sounding = forall a. (a -> Bool) -> [a] -> [a]
filter (Key -> SoundingNote -> Bool
key_sounding Key
key) [SoundingNote]
active
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SoundingNote]
sounding) forall a b. (a -> b) -> a -> b
$
        Text -> SynthM ()
warn forall a b. (a -> b) -> a -> b
$ Text
"sounding notes: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [SoundingNote]
sounding
    Channel
channel <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets forall a b. (a -> b) -> a -> b
$ Addr -> State -> Channel
MState.get_channel Addr
addr forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> State
state_channel
    PbRange
pb_range <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets forall a b. (a -> b) -> a -> b
$ Addr -> State -> PbRange
get_pb_range Addr
addr
    Addr -> ([SoundingNote] -> [SoundingNote]) -> SynthM ()
modify_notes Addr
addr (PbRange
-> Channel -> Addr -> RealTime -> Key -> Channel -> SoundingNote
make_note PbRange
pb_range Channel
channel Addr
addr RealTime
ts Key
key Channel
vel :)

make_note :: PbRange -> MState.Channel -> Addr -> RealTime -> Midi.Key
    -> Midi.Velocity -> SoundingNote
make_note :: PbRange
-> Channel -> Addr -> RealTime -> Key -> Channel -> SoundingNote
make_note PbRange
pb_range Channel
state Addr
addr RealTime
start Key
key Channel
vel = Note
    { note_start :: RealTime
note_start = RealTime
start
    , note_end :: Maybe RealTime
note_end = forall a. Maybe a
Nothing
    , note_key :: Key
note_key = Key
key
    , note_vel :: Channel
note_vel = Channel
vel
    , note_pitch :: NoteNumber
note_pitch = PbRange -> Key -> PitchBendValue -> NoteNumber
convert_pitch PbRange
pb_range Key
key (Channel -> PitchBendValue
MState.chan_pb Channel
state)
    , note_pitches :: [(RealTime, NoteNumber)]
note_pitches = []
    , note_controls :: ControlMap
note_controls = forall {b}. b -> [(RealTime, b)]
here forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Channel -> Map Control Channel
MState.chan_controls Channel
state
    , note_addr :: Addr
note_addr = Addr
addr
    }
    where here :: b -> [(RealTime, b)]
here b
val = [(RealTime
start, b
val)]

note_off :: Addr -> RealTime -> Midi.Key -> SynthM ()
note_off :: Addr -> RealTime -> Key -> SynthM ()
note_off Addr
addr RealTime
ts Key
key = do
    [SoundingNote]
active <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Addr
addr forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map Addr [SoundingNote]
state_active
    let ([SoundingNote]
sounding, [SoundingNote]
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition (Key -> SoundingNote -> Bool
key_sounding Key
key) [SoundingNote]
active
    case [SoundingNote]
sounding of
        [] -> Text -> SynthM ()
warn Text
"no sounding notes"
        SoundingNote
n : [SoundingNote]
ns -> do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SoundingNote]
ns) forall a b. (a -> b) -> a -> b
$
                Text -> SynthM ()
warn forall a b. (a -> b) -> a -> b
$ Text
"multiple sounding notes: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [SoundingNote]
sounding
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RealTime
ts forall a. Num a => a -> a -> a
- forall end. NoteT end -> RealTime
note_start SoundingNote
n forall a. Ord a => a -> a -> Bool
< RealTime
0.01) forall a b. (a -> b) -> a -> b
$
                Text -> SynthM ()
warn forall a b. (a -> b) -> a -> b
$ Text
"short note: dur " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (RealTime
ts forall a. Num a => a -> a -> a
- forall end. NoteT end -> RealTime
note_start SoundingNote
n)
                    forall a. Semigroup a => a -> a -> a
<> Text
" of " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty SoundingNote
n
            Addr -> ([SoundingNote] -> [SoundingNote]) -> SynthM ()
modify_notes Addr
addr forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
                SoundingNote
n { note_end :: Maybe RealTime
note_end = forall a. a -> Maybe a
Just RealTime
ts } forall a. a -> [a] -> [a]
: [SoundingNote]
rest

key_sounding :: Midi.Key -> SoundingNote -> Bool
key_sounding :: Key -> SoundingNote -> Bool
key_sounding Key
key SoundingNote
n = forall end. NoteT end -> end
note_end SoundingNote
n forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing Bool -> Bool -> Bool
&& forall end. NoteT end -> Key
note_key SoundingNote
n forall a. Eq a => a -> a -> Bool
== Key
key

-- | Append a CC change to all sounding notes.
control :: Addr -> RealTime -> MState.Control -> Midi.ControlValue -> SynthM ()
control :: Addr -> RealTime -> Control -> Channel -> SynthM ()
control Addr
addr RealTime
ts Control
control Channel
val = Addr -> ([SoundingNote] -> [SoundingNote]) -> SynthM ()
modify_notes Addr
addr (forall a b. (a -> b) -> [a] -> [b]
map forall {end}. NoteT end -> NoteT end
insert)
    where
    insert :: NoteT end -> NoteT end
insert NoteT end
note = NoteT end
note { note_controls :: ControlMap
note_controls =
        forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. [a] -> [a] -> [a]
(++) Control
control [(RealTime
ts, Channel
val)] (forall end. NoteT end -> ControlMap
note_controls NoteT end
note) }

-- | Append pitch bend to all sounding notes.
pitch_bend :: Addr -> RealTime -> Midi.PitchBendValue -> SynthM ()
pitch_bend :: Addr -> RealTime -> PitchBendValue -> SynthM ()
pitch_bend Addr
addr RealTime
ts PitchBendValue
val = do
    PbRange
pb_range <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets forall a b. (a -> b) -> a -> b
$ Addr -> State -> PbRange
get_pb_range Addr
addr
    Addr -> ([SoundingNote] -> [SoundingNote]) -> SynthM ()
modify_notes Addr
addr (forall a b. (a -> b) -> [a] -> [b]
map (forall {end}. PbRange -> NoteT end -> NoteT end
insert PbRange
pb_range))
    where
    insert :: PbRange -> NoteT end -> NoteT end
insert PbRange
pb_range NoteT end
note = NoteT end
note { note_pitches :: [(RealTime, NoteNumber)]
note_pitches =
        (RealTime
ts, PbRange -> Key -> PitchBendValue -> NoteNumber
convert_pitch PbRange
pb_range (forall end. NoteT end -> Key
note_key NoteT end
note) PitchBendValue
val) forall a. a -> [a] -> [a]
: forall end. NoteT end -> [(RealTime, NoteNumber)]
note_pitches NoteT end
note }

convert_pitch :: PbRange -> Midi.Key -> Midi.PitchBendValue -> Pitch.NoteNumber
convert_pitch :: PbRange -> Key -> PitchBendValue -> NoteNumber
convert_pitch (NoteNumber
down, NoteNumber
up) Key
key PitchBendValue
val = forall a. Num a => Key -> a
Midi.from_key Key
key forall a. Num a => a -> a -> a
+ PitchBendValue -> NoteNumber
convert PitchBendValue
val
    where
    convert :: PitchBendValue -> NoteNumber
convert PitchBendValue
v
        | PitchBendValue
v forall a. Ord a => a -> a -> Bool
>= PitchBendValue
0 = forall a. Real a => a -> NoteNumber
Pitch.nn (PitchBendValue -> Double
Num.f2d PitchBendValue
v) forall a. Num a => a -> a -> a
* NoteNumber
up
        | Bool
otherwise = forall a. Real a => a -> NoteNumber
Pitch.nn (- (PitchBendValue -> Double
Num.f2d PitchBendValue
v)) forall a. Num a => a -> a -> a
* NoteNumber
down

modify_notes :: Addr -> ([SoundingNote] -> [SoundingNote]) -> SynthM ()
modify_notes :: Addr -> ([SoundingNote] -> [SoundingNote]) -> SynthM ()
modify_notes Addr
addr [SoundingNote] -> [SoundingNote]
f = do
    Map Addr [SoundingNote]
active <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets State -> Map Addr [SoundingNote]
state_active
    let notes :: [SoundingNote]
notes = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Addr
addr Map Addr [SoundingNote]
active
    (State -> State) -> SynthM ()
modify forall a b. (a -> b) -> a -> b
$ \State
state -> State
state
        { state_active :: Map Addr [SoundingNote]
state_active = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Addr
addr ([SoundingNote] -> [SoundingNote]
f [SoundingNote]
notes) (State -> Map Addr [SoundingNote]
state_active State
state) }

-- * util

warn :: Text -> SynthM ()
warn :: Text -> SynthM ()
warn Text
msg = do
    WriteMessage
wmsg <- forall r (m :: * -> *). MonadReader r m => m r
Reader.ask
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify forall a b. (a -> b) -> a -> b
$ \State
state ->
        State
state { state_warns :: [(WriteMessage, Text)]
state_warns = (WriteMessage
wmsg, Text
msg) forall a. a -> [a] -> [a]
: State -> [(WriteMessage, Text)]
state_warns State
state }


-- * pretty

-- | Format synth state in an easier to read way.
pretty_state :: State -> Text
pretty_state :: State -> Text
pretty_state (State Map Addr PbRange
_pb_range State
_chan Map Addr [SoundingNote]
active [Note]
notes [(WriteMessage, Text)]
warns) =
    Text -> [Text] -> Text
Text.intercalate Text
"\n" forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Text
a, [Text]
b) -> Text
"  " forall a. Semigroup a => a -> a -> a
<> Text
a forall a. a -> [a] -> [a]
: [Text]
b) forall a b. (a -> b) -> a -> b
$
    forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
        [ (Text
"active:", forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Text
pretty (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall k a. Map k a -> [a]
Map.elems Map Addr [SoundingNote]
active)))
        , (Text
"warns:", forall a b. (a -> b) -> [a] -> [b]
map (WriteMessage, Text) -> Text
pretty_warn [(WriteMessage, Text)]
warns)
        , (Text
"notes:", forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Text
pretty [Note]
notes)
        ]

instance Pretty end => Pretty (NoteT end) where
    pretty :: NoteT end -> Text
pretty (Note RealTime
start end
end Key
key Channel
vel NoteNumber
pitch0 [(RealTime, NoteNumber)]
pitches1 ControlMap
controls (WriteDevice
dev, Channel
chan)) =
        [Text] -> Text
Text.unwords forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null)
            [ Text
addr_s, forall a. Pretty a => a -> Text
pretty Key
key
            , forall a. Pretty a => a -> Text
pretty RealTime
start forall a. Semigroup a => a -> a -> a
<> Text
"--" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty end
end forall a. Semigroup a => a -> a -> a
<> Text
":"
            , Text
"vel:" forall a. Semigroup a => a -> a -> a
<> forall a. (Integral a, Show a) => Int -> a -> Text
Num.hex Int
2 Channel
vel
            , if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(RealTime, NoteNumber)]
pitches then Text
"" else Text
"p:" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [(RealTime, NoteNumber)]
pitches
            , if forall k a. Map k a -> Bool
Map.null ControlMap
controls then Text
""
                else Text
"c:" forall a. Semigroup a => a -> a -> a
<> ControlMap -> Text
pretty_controls ControlMap
controls
            ]
        where
        pitches :: [(RealTime, NoteNumber)]
pitches = forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((forall a. Eq a => a -> a -> Bool
== forall a. Num a => Key -> a
Midi.from_key Key
key) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
            (RealTime
start, NoteNumber
pitch0) forall a. a -> [a] -> [a]
: [(RealTime, NoteNumber)]
pitches1
        addr_s :: Text
addr_s = forall a. Pretty a => a -> Text
pretty WriteDevice
dev forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Channel
chan

pretty_controls :: ControlMap -> Text
pretty_controls :: ControlMap -> Text
pretty_controls ControlMap
controls = Text -> [Text] -> Text
Text.intercalate Text
"\n\t"
    [forall a. Show a => a -> Text
showt Control
cont forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [(RealTime, Channel)]
vals | (Control
cont, [(RealTime, Channel)]
vals) <- forall k a. Map k a -> [(k, a)]
Map.assocs ControlMap
controls]

pretty_warn :: (Midi.WriteMessage, Text) -> Text
pretty_warn :: (WriteMessage, Text) -> Text
pretty_warn (Midi.WriteMessage WriteDevice
dev RealTime
ts (Midi.ChannelMessage Channel
chan ChannelMessage
msg), Text
warn) =
    forall a. Pretty a => a -> Text
pretty RealTime
ts forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty WriteDevice
dev forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Channel
chan
        forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty ChannelMessage
msg forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
warn
pretty_warn (Midi.WriteMessage WriteDevice
dev RealTime
ts Message
msg, Text
warn) =
    forall a. Pretty a => a -> Text
pretty RealTime
ts forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty WriteDevice
dev forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Message
msg forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
warn