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

{- | Convert incoming MIDI (and other inputs) to the internal note
    representation.  This has two purposes: note entry, and midi thru.

    This module is, in a way, dual to "Perform.Midi.Perform".  It takes MIDI
    input to the internal 'Input' representation and back again, while Perform
    takes the internal representation, in the form of
    'Perform.Midi.Perform.Event', to MIDI output.

    The overlapping part is that this module maps 'Derive.ScoreT.Control's to
    and from MIDI while Play uses 'Perform.Midi.Control.Control'.  They
    use the same control names, though, so I can reuse code from Control.

    One significant difference between 'Input' and MIDI is that MIDI supports
    two levels of control addressing: note and channel, while 'Input' can
    only represent note addressing through 'NoteId'.  MIDI controls almost
    all apply at the channel level, but of course these controls all apply
    at the note level.  The result is that a MIDI control that on a keyboard
    affects the whole channel will only affect the last played note here.  When
    the input is converted back to MIDI it may wind up sharing a channel
    anyway, at which point the control will go back to being channel global,
    but if the instrument has multiple channels, I try to distribute between
    them to keep note_ids on separate channels.  This way, multiple channel
    emitting controls can be mapped to multiple channel using instruments.

    This is basically a simplified version of the channel allocation algorithm
    in "Perform.Midi.Perform".  It's hard to reuse that algorithm directly
    because this one has to operate in realtime and can't see which controls
    the note is going to use.
-}
module Cmd.InputNote where
import qualified Data.Map as Map
import qualified Data.Text as Text

import qualified Util.Maps as Maps
import qualified Util.Num as Num
import qualified App.Config as Config
import qualified Derive.Controls as Controls
import qualified Derive.Scale.Theory as Theory
import qualified Derive.ScoreT as ScoreT

import qualified Midi.Midi as Midi
import qualified Perform.Midi.Control as Control
import qualified Perform.Pitch as Pitch
import qualified Perform.Signal as Signal

import           Global


-- | Since the ASCII keyboard isn't pressure sensitive, this is the default
-- velocity.  Hopefully it's strong but not so strong as to be hard on the
-- ears.
keyboard_velocity :: Signal.Y
keyboard_velocity :: Y
keyboard_velocity = Y
0.75

type Input = GenericInput Pitch.Input

-- | An input with a plain NoteNumber pitch instead of a 'Pitch.Input'.
type InputNn = GenericInput Pitch.NoteNumber

data GenericInput pitch =
    -- | The Input and val (velocity) could be sent separately, but that
    -- would make converting this back into midi for thru harder.
    NoteOn NoteId pitch Signal.Y
    | NoteOff NoteId Signal.Y
    -- | Controls coming from MIDI are mapped to control names, since this is
    -- a superset of MIDI CC numbers, and may include non-MIDI as well.  But
    -- for MidiThru to map back to a CC number, I need 1:1 mapping between
    -- ScoreT.Controls and CC numbers.  This is what 'cc_to_control' and
    -- 'control_to_cc' provide.
    | Control NoteId ScoreT.Control Signal.Y
    -- | Pitch could also be a Control, but this way the pitch is typed.
    | PitchChange NoteId pitch
    deriving (GenericInput pitch -> GenericInput pitch -> Bool
(GenericInput pitch -> GenericInput pitch -> Bool)
-> (GenericInput pitch -> GenericInput pitch -> Bool)
-> Eq (GenericInput pitch)
forall pitch.
Eq pitch =>
GenericInput pitch -> GenericInput pitch -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GenericInput pitch -> GenericInput pitch -> Bool
$c/= :: forall pitch.
Eq pitch =>
GenericInput pitch -> GenericInput pitch -> Bool
== :: GenericInput pitch -> GenericInput pitch -> Bool
$c== :: forall pitch.
Eq pitch =>
GenericInput pitch -> GenericInput pitch -> Bool
Eq, Int -> GenericInput pitch -> ShowS
[GenericInput pitch] -> ShowS
GenericInput pitch -> String
(Int -> GenericInput pitch -> ShowS)
-> (GenericInput pitch -> String)
-> ([GenericInput pitch] -> ShowS)
-> Show (GenericInput pitch)
forall pitch. Show pitch => Int -> GenericInput pitch -> ShowS
forall pitch. Show pitch => [GenericInput pitch] -> ShowS
forall pitch. Show pitch => GenericInput pitch -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenericInput pitch] -> ShowS
$cshowList :: forall pitch. Show pitch => [GenericInput pitch] -> ShowS
show :: GenericInput pitch -> String
$cshow :: forall pitch. Show pitch => GenericInput pitch -> String
showsPrec :: Int -> GenericInput pitch -> ShowS
$cshowsPrec :: forall pitch. Show pitch => Int -> GenericInput pitch -> ShowS
Show)

instance (Show pitch, Pretty pitch) => Pretty (GenericInput pitch) where
    pretty :: GenericInput pitch -> Text
pretty (NoteOn NoteId
id pitch
pitch Y
vel) = [Text] -> Text
Text.unwords
        [Text
"NoteOn", Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NoteId -> Text
forall a. Show a => a -> Text
showt NoteId
id Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")", pitch -> Text
forall a. Pretty a => a -> Text
pretty pitch
pitch, Y -> Text
forall a. Pretty a => a -> Text
pretty Y
vel]
    pretty GenericInput pitch
input = GenericInput pitch -> Text
forall a. Show a => a -> Text
showt GenericInput pitch
input

input_id :: GenericInput x -> NoteId
input_id :: forall x. GenericInput x -> NoteId
input_id GenericInput x
input = case GenericInput x
input of
    NoteOn NoteId
note_id x
_ Y
_ -> NoteId
note_id
    NoteOff NoteId
note_id Y
_ -> NoteId
note_id
    Control NoteId
note_id Control
_ Y
_ -> NoteId
note_id
    PitchChange NoteId
note_id x
_ -> NoteId
note_id

-- | Modify the NodeId so that it won't collide with other NodeIds.
--
-- NoteIds are supposed to be unique for each Input.  However, in practice they
-- wind up being the MIDI NoteOn 'Midi.Key', for reasons described in 'NoteId'.
-- So if you want to emit MIDI thru for two notes with the same pitch (e.g.
-- dispatch a single pitch to two instruments), you need to give them different
-- NoteIds.  This function multiplies them such that they won't collide.
--
-- TODO This is a grody hack.  A better solution might be to make NoteId into
-- a (Channel, Int) pair.
offset_note_id :: Int -> GenericInput x -> GenericInput x
offset_note_id :: forall x. Int -> GenericInput x -> GenericInput x
offset_note_id Int
multiplier GenericInput x
input = case GenericInput x
input of
    NoteOn NoteId
note_id x
pitch Y
vel -> NoteId -> x -> Y -> GenericInput x
forall pitch. NoteId -> pitch -> Y -> GenericInput pitch
NoteOn (NoteId -> NoteId
modify NoteId
note_id) x
pitch Y
vel
    NoteOff NoteId
note_id Y
vel -> NoteId -> Y -> GenericInput x
forall pitch. NoteId -> Y -> GenericInput pitch
NoteOff (NoteId -> NoteId
modify NoteId
note_id) Y
vel
    Control NoteId
note_id Control
control Y
val -> NoteId -> Control -> Y -> GenericInput x
forall pitch. NoteId -> Control -> Y -> GenericInput pitch
Control (NoteId -> NoteId
modify NoteId
note_id) Control
control Y
val
    PitchChange NoteId
note_id x
pitch -> NoteId -> x -> GenericInput x
forall pitch. NoteId -> pitch -> GenericInput pitch
PitchChange (NoteId -> NoteId
modify NoteId
note_id) x
pitch
    where
    modify :: NoteId -> NoteId
modify (NoteId Int
n) = Int -> NoteId
NoteId (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
multiplier)

-- | In theory, NoteId is an arbitrary ID, but in practice it's the same as
-- the initial note on Midi.Key.  The reason is that pitch bend needs to
-- know the original key so it knows what the pitch bend is relative to.  I
-- could store the original key separately, but it's convenient to put them
-- both into NoteId, and I can't think of any instances where I'd want them
-- to be different.
--
-- In addition, when a MIDI NoteOff comes in I have to know what NoteId it
-- applies to.  Since MIDI's NoteId is the key number, I have no choice but to
-- use that.
newtype NoteId = NoteId Int deriving (NoteId -> NoteId -> Bool
(NoteId -> NoteId -> Bool)
-> (NoteId -> NoteId -> Bool) -> Eq NoteId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoteId -> NoteId -> Bool
$c/= :: NoteId -> NoteId -> Bool
== :: NoteId -> NoteId -> Bool
$c== :: NoteId -> NoteId -> Bool
Eq, Eq NoteId
Eq NoteId
-> (NoteId -> NoteId -> Ordering)
-> (NoteId -> NoteId -> Bool)
-> (NoteId -> NoteId -> Bool)
-> (NoteId -> NoteId -> Bool)
-> (NoteId -> NoteId -> Bool)
-> (NoteId -> NoteId -> NoteId)
-> (NoteId -> NoteId -> NoteId)
-> Ord NoteId
NoteId -> NoteId -> Bool
NoteId -> NoteId -> Ordering
NoteId -> NoteId -> NoteId
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 :: NoteId -> NoteId -> NoteId
$cmin :: NoteId -> NoteId -> NoteId
max :: NoteId -> NoteId -> NoteId
$cmax :: NoteId -> NoteId -> NoteId
>= :: NoteId -> NoteId -> Bool
$c>= :: NoteId -> NoteId -> Bool
> :: NoteId -> NoteId -> Bool
$c> :: NoteId -> NoteId -> Bool
<= :: NoteId -> NoteId -> Bool
$c<= :: NoteId -> NoteId -> Bool
< :: NoteId -> NoteId -> Bool
$c< :: NoteId -> NoteId -> Bool
compare :: NoteId -> NoteId -> Ordering
$ccompare :: NoteId -> NoteId -> Ordering
Ord, Int -> NoteId -> ShowS
[NoteId] -> ShowS
NoteId -> String
(Int -> NoteId -> ShowS)
-> (NoteId -> String) -> ([NoteId] -> ShowS) -> Show NoteId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoteId] -> ShowS
$cshowList :: [NoteId] -> ShowS
show :: NoteId -> String
$cshow :: NoteId -> String
showsPrec :: Int -> NoteId -> ShowS
$cshowsPrec :: Int -> NoteId -> ShowS
Show)

key_to_id :: Midi.Key -> NoteId
key_to_id :: Key -> NoteId
key_to_id = Int -> NoteId
NoteId (Int -> NoteId) -> (Key -> Int) -> Key -> NoteId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Int
forall a. Num a => Key -> a
Midi.from_key

id_to_key :: NoteId -> Midi.Key
id_to_key :: NoteId -> Key
id_to_key (NoteId Int
key) = Int -> Key
forall a. Integral a => a -> Key
Midi.to_key Int
key

-- * from midi

type Addr = (Midi.ReadDevice, Midi.Channel)

-- | Keep track of the state of each 'Midi.ReadDevice'.
newtype ReadDeviceState = ReadDeviceState (Map Midi.ReadDevice ControlState)
    deriving (ReadDeviceState -> ReadDeviceState -> Bool
(ReadDeviceState -> ReadDeviceState -> Bool)
-> (ReadDeviceState -> ReadDeviceState -> Bool)
-> Eq ReadDeviceState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReadDeviceState -> ReadDeviceState -> Bool
$c/= :: ReadDeviceState -> ReadDeviceState -> Bool
== :: ReadDeviceState -> ReadDeviceState -> Bool
$c== :: ReadDeviceState -> ReadDeviceState -> Bool
Eq, Int -> ReadDeviceState -> ShowS
[ReadDeviceState] -> ShowS
ReadDeviceState -> String
(Int -> ReadDeviceState -> ShowS)
-> (ReadDeviceState -> String)
-> ([ReadDeviceState] -> ShowS)
-> Show ReadDeviceState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReadDeviceState] -> ShowS
$cshowList :: [ReadDeviceState] -> ShowS
show :: ReadDeviceState -> String
$cshow :: ReadDeviceState -> String
showsPrec :: Int -> ReadDeviceState -> ShowS
$cshowsPrec :: Int -> ReadDeviceState -> ShowS
Show)

empty_rdev_state :: ReadDeviceState
empty_rdev_state :: ReadDeviceState
empty_rdev_state = Map ReadDevice ControlState -> ReadDeviceState
ReadDeviceState Map ReadDevice ControlState
forall a. Monoid a => a
mempty

next_state :: Midi.ReadDevice -> ControlState -> ReadDeviceState
    -> ReadDeviceState
next_state :: ReadDevice -> ControlState -> ReadDeviceState -> ReadDeviceState
next_state ReadDevice
rdev ControlState
cstate (ReadDeviceState Map ReadDevice ControlState
state) =
    Map ReadDevice ControlState -> ReadDeviceState
ReadDeviceState (Map ReadDevice ControlState -> ReadDeviceState)
-> Map ReadDevice ControlState -> ReadDeviceState
forall a b. (a -> b) -> a -> b
$ ReadDevice
-> ControlState
-> Map ReadDevice ControlState
-> Map ReadDevice ControlState
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ReadDevice
rdev ControlState
cstate Map ReadDevice ControlState
state

-- | The state of one 'Midi.ReadDevice'.
data ControlState = ControlState
    { ControlState -> Map Addr NoteId
state_note_id :: Map Addr NoteId -- ^ last note_id
    , ControlState -> Map Addr PitchBendValue
state_pb :: Map Addr Midi.PitchBendValue -- ^ last pb
    , ControlState -> PbRange
state_pb_range :: Control.PbRange
    } deriving (ControlState -> ControlState -> Bool
(ControlState -> ControlState -> Bool)
-> (ControlState -> ControlState -> Bool) -> Eq ControlState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ControlState -> ControlState -> Bool
$c/= :: ControlState -> ControlState -> Bool
== :: ControlState -> ControlState -> Bool
$c== :: ControlState -> ControlState -> Bool
Eq, Int -> ControlState -> ShowS
[ControlState] -> ShowS
ControlState -> String
(Int -> ControlState -> ShowS)
-> (ControlState -> String)
-> ([ControlState] -> ShowS)
-> Show ControlState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ControlState] -> ShowS
$cshowList :: [ControlState] -> ShowS
show :: ControlState -> String
$cshow :: ControlState -> String
showsPrec :: Int -> ControlState -> ShowS
$cshowsPrec :: Int -> ControlState -> ShowS
Show)

empty_control_state :: Control.PbRange -> ControlState
empty_control_state :: PbRange -> ControlState
empty_control_state PbRange
pb_range = ControlState
    { state_note_id :: Map Addr NoteId
state_note_id = Map Addr NoteId
forall k a. Map k a
Map.empty
    , state_pb :: Map Addr PitchBendValue
state_pb = Map Addr PitchBendValue
forall k a. Map k a
Map.empty
    , state_pb_range :: PbRange
state_pb_range = PbRange
pb_range
    }

from_midi :: ReadDeviceState -> Midi.ReadDevice -> Midi.Message
    -> Maybe (Input, ReadDeviceState)
from_midi :: ReadDeviceState
-> ReadDevice -> Message -> Maybe (Input, ReadDeviceState)
from_midi (ReadDeviceState Map ReadDevice ControlState
state) ReadDevice
rdev (Midi.ChannelMessage Control
chan ChannelMessage
chan_msg) =
    case Maybe Input
maybe_input of
        Maybe Input
Nothing -> Maybe (Input, ReadDeviceState)
forall a. Maybe a
Nothing
        Just Input
input -> (Input, ReadDeviceState) -> Maybe (Input, ReadDeviceState)
forall a. a -> Maybe a
Just (Input
input, ReadDeviceState
next_state)
    where
    next_state :: ReadDeviceState
next_state = Map ReadDevice ControlState -> ReadDeviceState
ReadDeviceState (Map ReadDevice ControlState -> ReadDeviceState)
-> Map ReadDevice ControlState -> ReadDeviceState
forall a b. (a -> b) -> a -> b
$
        ReadDevice
-> ControlState
-> Map ReadDevice ControlState
-> Map ReadDevice ControlState
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ReadDevice
rdev (Addr -> ChannelMessage -> ControlState -> ControlState
update_control_state Addr
addr ChannelMessage
chan_msg ControlState
cstate) Map ReadDevice ControlState
state
    cstate :: ControlState
cstate = ControlState
-> ReadDevice -> Map ReadDevice ControlState -> ControlState
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault
        (PbRange -> ControlState
empty_control_state PbRange
Config.read_device_pb_range) ReadDevice
rdev Map ReadDevice ControlState
state
    addr :: Addr
addr = (ReadDevice
rdev, Control
chan)
    last_pb :: PitchBendValue
last_pb = PitchBendValue -> Addr -> Map Addr PitchBendValue -> PitchBendValue
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault PitchBendValue
0 Addr
addr (ControlState -> Map Addr PitchBendValue
state_pb ControlState
cstate)
    with_last_id :: (NoteId -> b) -> Maybe b
with_last_id NoteId -> b
f = (NoteId -> b) -> Maybe NoteId -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NoteId -> b
f (Addr -> Map Addr NoteId -> Maybe NoteId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Addr
addr (ControlState -> Map Addr NoteId
state_note_id ControlState
cstate))
    maybe_input :: Maybe Input
maybe_input = case ChannelMessage
chan_msg of
        Midi.NoteOn Key
key Control
vel -> Input -> Maybe Input
forall a. a -> Maybe a
Just (Input -> Maybe Input) -> Input -> Maybe Input
forall a b. (a -> b) -> a -> b
$
            NoteId -> Input -> Y -> Input
forall pitch. NoteId -> pitch -> Y -> GenericInput pitch
NoteOn (Key -> NoteId
key_to_id Key
key) (PitchBendValue -> Key -> Input
to_pitch PitchBendValue
last_pb Key
key) (Control -> Y
forall {a} {a}. (Fractional a, Integral a) => a -> a
to_val Control
vel)
        Midi.NoteOff Key
key Control
vel -> Input -> Maybe Input
forall a. a -> Maybe a
Just (Input -> Maybe Input) -> Input -> Maybe Input
forall a b. (a -> b) -> a -> b
$
            NoteId -> Y -> Input
forall pitch. NoteId -> Y -> GenericInput pitch
NoteOff (Key -> NoteId
key_to_id Key
key) (Control -> Y
forall {a} {a}. (Fractional a, Integral a) => a -> a
to_val Control
vel)
        Midi.ControlChange Control
cc Control
val -> (NoteId -> Input) -> Maybe Input
forall {b}. (NoteId -> b) -> Maybe b
with_last_id ((NoteId -> Input) -> Maybe Input)
-> (NoteId -> Input) -> Maybe Input
forall a b. (a -> b) -> a -> b
$ \NoteId
last_id ->
            NoteId -> Control -> Y -> Input
forall pitch. NoteId -> Control -> Y -> GenericInput pitch
Control NoteId
last_id (Control -> Control
cc_to_control Control
cc) (Control -> Y
forall {a} {a}. (Fractional a, Integral a) => a -> a
to_val Control
val)
        Midi.PitchBend PitchBendValue
val -> (NoteId -> Input) -> Maybe Input
forall {b}. (NoteId -> b) -> Maybe b
with_last_id ((NoteId -> Input) -> Maybe Input)
-> (NoteId -> Input) -> Maybe Input
forall a b. (a -> b) -> a -> b
$ \NoteId
last_id ->
            NoteId -> Input -> Input
forall pitch. NoteId -> pitch -> GenericInput pitch
PitchChange NoteId
last_id (PitchBendValue -> Key -> Input
to_pitch PitchBendValue
val (NoteId -> Key
id_to_key NoteId
last_id))
        Midi.Aftertouch Key
key Control
val -> Input -> Maybe Input
forall a. a -> Maybe a
Just (Input -> Maybe Input) -> Input -> Maybe Input
forall a b. (a -> b) -> a -> b
$
            NoteId -> Control -> Y -> Input
forall pitch. NoteId -> Control -> Y -> GenericInput pitch
Control (Key -> NoteId
key_to_id Key
key) Control
Controls.aftertouch (Control -> Y
forall {a} {a}. (Fractional a, Integral a) => a -> a
to_val Control
val)
        Midi.ChannelPressure Control
val -> (NoteId -> Input) -> Maybe Input
forall {b}. (NoteId -> b) -> Maybe b
with_last_id ((NoteId -> Input) -> Maybe Input)
-> (NoteId -> Input) -> Maybe Input
forall a b. (a -> b) -> a -> b
$ \NoteId
last_id ->
            NoteId -> Control -> Y -> Input
forall pitch. NoteId -> Control -> Y -> GenericInput pitch
Control NoteId
last_id Control
Controls.pressure (Control -> Y
forall {a} {a}. (Fractional a, Integral a) => a -> a
to_val Control
val)
        ChannelMessage
_ -> Maybe Input
forall a. Maybe a
Nothing
    to_pitch :: PitchBendValue -> Key -> Input
to_pitch = PbRange -> PitchBendValue -> Key -> Input
pb_to_input (ControlState -> PbRange
state_pb_range ControlState
cstate)
    to_val :: a -> a
to_val a
v = a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
v a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
127
from_midi ReadDeviceState
_ ReadDevice
_ Message
_ = Maybe (Input, ReadDeviceState)
forall a. Maybe a
Nothing

update_control_state :: Addr -> Midi.ChannelMessage -> ControlState
    -> ControlState
update_control_state :: Addr -> ChannelMessage -> ControlState -> ControlState
update_control_state Addr
addr ChannelMessage
chan_msg ControlState
state = ControlState
state
    { state_note_id :: Map Addr NoteId
state_note_id = case ChannelMessage -> Maybe NoteId
id_of ChannelMessage
chan_msg of
        Maybe NoteId
Nothing -> ControlState -> Map Addr NoteId
state_note_id ControlState
state
        Just NoteId
note_id -> Addr -> NoteId -> Map Addr NoteId -> Map Addr NoteId
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Addr
addr NoteId
note_id (ControlState -> Map Addr NoteId
state_note_id ControlState
state)
    , state_pb :: Map Addr PitchBendValue
state_pb = case ChannelMessage -> Maybe PitchBendValue
pb_of ChannelMessage
chan_msg of
        Maybe PitchBendValue
Nothing -> ControlState -> Map Addr PitchBendValue
state_pb ControlState
state
        Just PitchBendValue
pb -> Addr
-> PitchBendValue
-> Map Addr PitchBendValue
-> Map Addr PitchBendValue
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Addr
addr PitchBendValue
pb (ControlState -> Map Addr PitchBendValue
state_pb ControlState
state)
    }
    where
    pb_of :: ChannelMessage -> Maybe PitchBendValue
pb_of (Midi.PitchBend PitchBendValue
val) = PitchBendValue -> Maybe PitchBendValue
forall a. a -> Maybe a
Just PitchBendValue
val
    pb_of ChannelMessage
_ = Maybe PitchBendValue
forall a. Maybe a
Nothing
    id_of :: ChannelMessage -> Maybe NoteId
id_of (Midi.NoteOn Key
key Control
_) = NoteId -> Maybe NoteId
forall a. a -> Maybe a
Just (Key -> NoteId
key_to_id Key
key)
    id_of (Midi.NoteOff Key
key Control
_) = NoteId -> Maybe NoteId
forall a. a -> Maybe a
Just (Key -> NoteId
key_to_id Key
key)
    id_of ChannelMessage
_ = Maybe NoteId
forall a. Maybe a
Nothing

pb_to_input :: Control.PbRange -> Midi.PitchBendValue -> Midi.Key -> Pitch.Input
pb_to_input :: PbRange -> PitchBendValue -> Key -> Input
pb_to_input (Int
low, Int
high) PitchBendValue
pb Key
key =
    NoteNumber -> Input
nn_to_input (NoteNumber -> Input) -> NoteNumber -> Input
forall a b. (a -> b) -> a -> b
$ Key -> NoteNumber
forall a. Num a => Key -> a
Midi.from_key Key
key NoteNumber -> NoteNumber -> NoteNumber
forall a. Num a => a -> a -> a
+ Y -> NoteNumber
forall a. Real a => a -> NoteNumber
Pitch.nn Y
offset
    where
    offset :: Y
offset = PitchBendValue -> Y
Num.f2d (PitchBendValue -> Y) -> PitchBendValue -> Y
forall a b. (a -> b) -> a -> b
$
        if PitchBendValue
pb PitchBendValue -> PitchBendValue -> Bool
forall a. Ord a => a -> a -> Bool
< PitchBendValue
0 then -PitchBendValue
pb PitchBendValue -> PitchBendValue -> PitchBendValue
forall a. Num a => a -> a -> a
* Int -> PitchBendValue
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
low else PitchBendValue
pb PitchBendValue -> PitchBendValue -> PitchBendValue
forall a. Num a => a -> a -> a
* Int -> PitchBendValue
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
high

nn_to_input :: Pitch.NoteNumber -> Pitch.Input
nn_to_input :: NoteNumber -> Input
nn_to_input NoteNumber
nn = KbdType -> Pitch -> Y -> Input
Pitch.Input KbdType
Pitch.PianoKbd Pitch
pitch Y
frac
    where
    pitch :: Pitch
pitch = Layout -> Int -> Pitch
Theory.semis_to_pitch_sharps Layout
Theory.piano_layout (Int -> Pitch) -> Int -> Pitch
forall a b. (a -> b) -> a -> b
$
        Int -> Int
Theory.nn_to_semis Int
key
    (Int
key, Y
frac) = Y -> (Int, Y)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction (NoteNumber -> Y
Pitch.nn_to_double NoteNumber
nn)

input_to_nn :: Pitch.Input -> Pitch.NoteNumber
input_to_nn :: Input -> NoteNumber
input_to_nn (Pitch.Input KbdType
_ Pitch
pitch Y
frac) = NoteNumber
nn NoteNumber -> NoteNumber -> NoteNumber
forall a. Num a => a -> a -> a
+ Y -> NoteNumber
forall a. Real a => a -> NoteNumber
Pitch.nn Y
frac
    where nn :: NoteNumber
nn = Int -> NoteNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Pitch -> Int
pitch_to_nn Pitch
pitch)

cc_to_control :: Midi.Control -> ScoreT.Control
cc_to_control :: Control -> Control
cc_to_control Control
cc = Control -> Maybe Control -> Control
forall a. a -> Maybe a -> a
fromMaybe (Text -> Control
ScoreT.unchecked_control (Text
"cc" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Control -> Text
forall a. Show a => a -> Text
showt Control
cc))
    (Control -> Map Control Control -> Maybe Control
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Control
cc Map Control Control
cc_control)

control_to_cc :: ScoreT.Control -> Maybe Midi.Control
control_to_cc :: Control -> Maybe Control
control_to_cc = (Control -> Map Control Control -> Maybe Control)
-> Map Control Control -> Control -> Maybe Control
forall a b c. (a -> b -> c) -> b -> a -> c
flip Control -> Map Control Control -> Maybe Control
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map Control Control
control_cc

cc_control :: Map Midi.Control ScoreT.Control
cc_control :: Map Control Control
cc_control = Map Control Control -> Map Control Control
forall a k. Ord a => Map k a -> Map a k
Maps.invert Map Control Control
control_cc

control_cc :: Map ScoreT.Control Midi.Control
control_cc :: Map Control Control
control_cc = Map Control Control
Control.universal_control_map

-- * from ascii

-- | Create an Input from an ascii keyboard Pitch.
from_ascii :: Bool -> Pitch.Pitch -> Input
from_ascii :: Bool -> Pitch -> Input
from_ascii Bool
down Pitch
pitch
    | Bool
down = NoteId -> Input -> Y -> Input
forall pitch. NoteId -> pitch -> Y -> GenericInput pitch
NoteOn NoteId
note_id (KbdType -> Pitch -> Y -> Input
Pitch.Input KbdType
Pitch.AsciiKbd Pitch
pitch Y
0)
        Y
keyboard_velocity
    | Bool
otherwise = NoteId -> Y -> Input
forall pitch. NoteId -> Y -> GenericInput pitch
NoteOff NoteId
note_id Y
keyboard_velocity
    where note_id :: NoteId
note_id = Int -> NoteId
NoteId (Pitch -> Int
pitch_to_nn Pitch
pitch)

pitch_to_nn :: Pitch.Pitch -> Int
pitch_to_nn :: Pitch -> Int
pitch_to_nn = Int -> Int
Theory.semis_to_nn (Int -> Int) -> (Pitch -> Int) -> Pitch -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Layout -> Pitch -> Int
Theory.pitch_to_semis Layout
Theory.piano_layout

-- * to midi

-- | Convert an InputNn to MIDI.
to_midi :: Control.PbRange -> Map NoteId Midi.Key -> InputNn
    -> ([Midi.ChannelMessage], Map NoteId Midi.Key)
to_midi :: PbRange
-> Map NoteId Key -> InputNn -> ([ChannelMessage], Map NoteId Key)
to_midi PbRange
pb_range Map NoteId Key
id_to_key = \case
    NoteOn NoteId
note_id NoteNumber
nn Y
vel -> NoteId -> NoteNumber -> Y -> ([ChannelMessage], Map NoteId Key)
forall {a}.
RealFrac a =>
NoteId -> NoteNumber -> a -> ([ChannelMessage], Map NoteId Key)
note_on NoteId
note_id NoteNumber
nn Y
vel
    NoteOff NoteId
note_id Y
vel -> NoteId
-> (Key -> ([ChannelMessage], Map NoteId Key))
-> ([ChannelMessage], Map NoteId Key)
forall {a}.
NoteId -> (Key -> ([a], Map NoteId Key)) -> ([a], Map NoteId Key)
with_key NoteId
note_id ((Key -> ([ChannelMessage], Map NoteId Key))
 -> ([ChannelMessage], Map NoteId Key))
-> (Key -> ([ChannelMessage], Map NoteId Key))
-> ([ChannelMessage], Map NoteId Key)
forall a b. (a -> b) -> a -> b
$ \Key
key ->
        ([Key -> Control -> ChannelMessage
Midi.NoteOff Key
key (Y -> Control
forall {a} {b}. (RealFrac a, Integral b) => a -> b
from_val Y
vel)], NoteId -> Map NoteId Key -> Map NoteId Key
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete NoteId
note_id Map NoteId Key
id_to_key)
    PitchChange NoteId
note_id NoteNumber
nn -> NoteId
-> (Key -> ([ChannelMessage], Map NoteId Key))
-> ([ChannelMessage], Map NoteId Key)
forall {a}.
NoteId -> (Key -> ([a], Map NoteId Key)) -> ([a], Map NoteId Key)
with_key NoteId
note_id ((Key -> ([ChannelMessage], Map NoteId Key))
 -> ([ChannelMessage], Map NoteId Key))
-> (Key -> ([ChannelMessage], Map NoteId Key))
-> ([ChannelMessage], Map NoteId Key)
forall a b. (a -> b) -> a -> b
$ \Key
key ->
        ([PitchBendValue -> ChannelMessage
Midi.PitchBend (PbRange -> Key -> NoteNumber -> PitchBendValue
Control.pb_from_nn PbRange
pb_range Key
key NoteNumber
nn)], Map NoteId Key
id_to_key)
    Control NoteId
_ Control
control Y
val -> case Control -> Maybe Control
control_to_cc Control
control of
        Maybe Control
Nothing -> ([], Map NoteId Key
id_to_key)
        Just Control
cc -> ([Control -> Control -> ChannelMessage
Midi.ControlChange Control
cc (Y -> Control
forall {a} {b}. (RealFrac a, Integral b) => a -> b
from_val Y
val)], Map NoteId Key
id_to_key)
    where
    with_key :: NoteId -> (Key -> ([a], Map NoteId Key)) -> ([a], Map NoteId Key)
with_key NoteId
note_id Key -> ([a], Map NoteId Key)
f = case NoteId -> Map NoteId Key -> Maybe Key
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NoteId
note_id Map NoteId Key
id_to_key of
        Maybe Key
Nothing -> ([], Map NoteId Key
id_to_key)
        Just Key
key -> Key -> ([a], Map NoteId Key)
f Key
key
    from_val :: a -> b
from_val a
val = a -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (a
val a -> a -> a
forall a. Num a => a -> a -> a
* a
127)
    note_on :: NoteId -> NoteNumber -> a -> ([ChannelMessage], Map NoteId Key)
note_on NoteId
note_id NoteNumber
nn a
vel = case PbRange -> NoteNumber -> Maybe (Key, PitchBendValue)
Control.pitch_to_midi PbRange
pb_range NoteNumber
nn of
        Maybe (Key, PitchBendValue)
Nothing -> ([], Map NoteId Key
id_to_key)
        Just (Key
key, PitchBendValue
pb) ->
            ( [PitchBendValue -> ChannelMessage
Midi.PitchBend PitchBendValue
pb, Key -> Control -> ChannelMessage
Midi.NoteOn Key
key (a -> Control
forall {a} {b}. (RealFrac a, Integral b) => a -> b
from_val a
vel)]
            , NoteId -> Key -> Map NoteId Key -> Map NoteId Key
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert NoteId
note_id Key
key Map NoteId Key
id_to_key
            )