-- 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 a midi file to a block.
module Cmd.Load.Midi (
    load
    , parse, convert
    -- * testing
    , Midi, NoteTrack(..)
    , convert_tracks, split_track, collect_notes
) where
import qualified Data.IntMap.Strict as IntMap
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Data.Word as Word

import qualified ZMidi.Core as Z

import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Maps as Maps

import qualified Cmd.Cmd as Cmd
import qualified Cmd.Create as Create
import qualified Derive.Attrs as Attrs
import qualified Derive.Controls as Controls
import qualified Derive.ParseTitle as ParseTitle
import qualified Derive.Scale.Twelve as Twelve
import qualified Derive.ScoreT as ScoreT
import qualified Derive.ShowVal as ShowVal

import qualified Instrument.Common as Common
import qualified Midi.Midi as Midi
import qualified Perform.Midi.Control as Control
import qualified Perform.Midi.Patch as Patch
import qualified Perform.Pitch as Pitch
import qualified Perform.RealTime as RealTime

import qualified Ui.Event as Event
import qualified Ui.Events as Events
import qualified Ui.Skeleton as Skeleton
import qualified Ui.Ui as Ui

import           Global
import           Types


type Warn = Text

load :: FilePath -> Cmd.CmdT IO BlockId
load :: FilePath -> CmdT IO BlockId
load FilePath
fn = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO (Either Text MidiFile)
parse FilePath
fn) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left Text
err -> forall (m :: * -> *) a. (Stack, M m) => Text -> m a
Cmd.throw forall a b. (a -> b) -> a -> b
$ Text
"parsing " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt FilePath
fn forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
err
    Right MidiFile
midi_file -> do
        let ([(Text, Track)]
tracks, Skeleton
skel, [Text]
warns) = MidiFile -> ([(Text, Track)], Skeleton, [Text])
convert MidiFile
midi_file
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath -> Text
txt FilePath
fn forall a. Semigroup a => a -> a -> a
<> Text
": ") <>)) [Text]
warns
        forall (m :: * -> *).
M m =>
[(Text, Track)] -> Skeleton -> m BlockId
create [(Text, Track)]
tracks Skeleton
skel

create :: Ui.M m => [(Text, Track)] -> Skeleton.Skeleton -> m BlockId
create :: forall (m :: * -> *).
M m =>
[(Text, Track)] -> Skeleton -> m BlockId
create [(Text, Track)]
tracks Skeleton
skel = do
    BlockId
block_id <- forall (m :: * -> *). M m => RulerId -> m BlockId
Create.block RulerId
Ui.no_ruler
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall {m :: * -> *}. M m => BlockId -> (Text, Track) -> m TrackId
add_track BlockId
block_id) [(Text, Track)]
tracks
    forall (m :: * -> *). M m => BlockId -> Skeleton -> m ()
Ui.set_skeleton BlockId
block_id Skeleton
skel
    forall (m :: * -> *) a. Monad m => a -> m a
return BlockId
block_id
    where
    add_track :: BlockId -> (Text, Track) -> m TrackId
add_track BlockId
block_id (Text
title, Track
track) =
        forall (m :: * -> *).
M m =>
BlockId -> Int -> Text -> Events -> m TrackId
Create.track BlockId
block_id Int
9999 Text
title forall a b. (a -> b) -> a -> b
$
            [Event] -> Events
Events.from_list [ScoreTime -> ScoreTime -> Text -> Event
Event.event ScoreTime
start ScoreTime
dur Text
text
                | (ScoreTime
start, (ScoreTime
dur, Text
text)) <- forall k a. Map k a -> [(k, a)]
Map.toAscList Track
track]

parse :: FilePath -> IO (Either Warn Z.MidiFile)
parse :: FilePath -> IO (Either Text MidiFile)
parse FilePath
fn = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErr -> Text
show_error forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Either ParseErr MidiFile)
Z.readMidi FilePath
fn
    where show_error :: ParseErr -> Text
show_error (Z.ParseErr Int
pos FilePath
msg) = forall a. Show a => a -> Text
showt Int
pos forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
txt FilePath
msg

convert :: Z.MidiFile -> ([(Text, Track)], Skeleton.Skeleton, [Warn])
convert :: MidiFile -> ([(Text, Track)], Skeleton, [Text])
convert = [(Text, [Midi])] -> ([(Text, Track)], Skeleton, [Text])
convert_tracks forall b c a. (b -> c) -> (a -> b) -> a -> c
. MidiFile -> [(Text, [Midi])]
extract_tracks

-- * extract

type Midi = (RealTime, Midi.Message)

extract_tracks :: Z.MidiFile -> [(Text, [Midi])]
extract_tracks :: MidiFile -> [(Text, [Midi])]
extract_tracks (Z.MidiFile MidiHeader
header [MidiTrack]
tracks) =
    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]
map (RealTime -> MidiTrack -> (Text, [Midi])
extract_track RealTime
per_sec) [MidiTrack]
tracks
    where
    per_sec :: RealTime
per_sec = Double -> RealTime
RealTime.seconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ case MidiHeader -> MidiTimeDivision
Z.time_division MidiHeader
header of
        Z.FPS Word16
val -> Word16
val
        Z.TPB Word16
val -> Word16
val

extract_track :: RealTime -> Z.MidiTrack -> (Text, [Midi])
extract_track :: RealTime -> MidiTrack -> (Text, [Midi])
extract_track RealTime
per_sec (Z.MidiTrack [MidiMessage]
msgs) =
    (Text
name, forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (RealTime, MidiEvent) -> [Midi]
extract_message (forall a b. [a] -> [b] -> [(a, b)]
zip [RealTime]
times (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [MidiMessage]
msgs)))
    where
    name :: Text
name = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" FilePath -> Text
txt forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
Lists.head
        [FilePath
name | Z.MetaEvent (Z.TextEvent MidiTextType
_ FilePath
name) <- forall a. Int -> [a] -> [a]
take Int
10 (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [MidiMessage]
msgs)]
    times :: [RealTime]
times = forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall a. Num a => a -> a -> a
(+) RealTime
0 forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Fractional a => a -> a -> a
/RealTime
per_sec) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> RealTime
RealTime.seconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [MidiMessage]
msgs

extract_message :: (RealTime, Z.MidiEvent) -> [Midi]
extract_message :: (RealTime, MidiEvent) -> [Midi]
extract_message (RealTime
time, MidiEvent
msg) = case MidiEvent
msg of
    Z.VoiceEvent MidiRunningStatus
_ MidiVoiceEvent
midi -> (forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) RealTime
time forall a b. (a -> b) -> a -> b
$ case MidiVoiceEvent
midi of
        Z.NoteOff Word8
chan Word8
key Word8
vel ->
            Word8 -> ChannelMessage -> Message
Midi.ChannelMessage Word8
chan (Key -> Word8 -> ChannelMessage
Midi.NoteOff (forall a. Integral a => a -> Key
Midi.to_key Word8
key) Word8
vel)
        Z.NoteOn Word8
chan Word8
key Word8
vel ->
            Word8 -> ChannelMessage -> Message
Midi.ChannelMessage Word8
chan (Key -> Word8 -> ChannelMessage
Midi.NoteOn (forall a. Integral a => a -> Key
Midi.to_key Word8
key) Word8
vel)
        Z.NoteAftertouch Word8
chan Word8
key Word8
val ->
            Word8 -> ChannelMessage -> Message
Midi.ChannelMessage Word8
chan (Key -> Word8 -> ChannelMessage
Midi.Aftertouch (forall a. Integral a => a -> Key
Midi.to_key Word8
key) Word8
val)
        Z.Controller Word8
chan Word8
cc Word8
val ->
            Word8 -> ChannelMessage -> Message
Midi.ChannelMessage Word8
chan (Word8 -> Word8 -> ChannelMessage
Midi.ControlChange Word8
cc Word8
val)
        Z.ProgramChange Word8
chan Word8
program ->
            Word8 -> ChannelMessage -> Message
Midi.ChannelMessage Word8
chan (Word8 -> ChannelMessage
Midi.ProgramChange Word8
program)
        Z.ChanAftertouch Word8
chan Word8
val ->
            Word8 -> ChannelMessage -> Message
Midi.ChannelMessage Word8
chan (Word8 -> ChannelMessage
Midi.ChannelPressure Word8
val)
        Z.PitchBend Word8
chan Word14
val ->
            Word8 -> ChannelMessage -> Message
Midi.ChannelMessage Word8
chan
                (PitchBendValue -> ChannelMessage
Midi.PitchBend (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word14
val forall a. Fractional a => a -> a -> a
/ PitchBendValue
2forall a b. (Num a, Integral b) => a -> b -> a
^Integer
13 forall a. Num a => a -> a -> a
- PitchBendValue
2forall a b. (Num a, Integral b) => a -> b -> a
^Integer
13))
    MidiEvent
_ -> []


-- * convert

-- | (note, pitch, controls)
data NoteTrack = NoteTrack Track Track (Map ScoreT.Control Track)
    deriving (Int -> NoteTrack -> ShowS
[NoteTrack] -> ShowS
NoteTrack -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [NoteTrack] -> ShowS
$cshowList :: [NoteTrack] -> ShowS
show :: NoteTrack -> FilePath
$cshow :: NoteTrack -> FilePath
showsPrec :: Int -> NoteTrack -> ShowS
$cshowsPrec :: Int -> NoteTrack -> ShowS
Show)
-- | Map start (dur, text)
type Track = Map ScoreTime (ScoreTime, Text)

instance Semigroup NoteTrack where
    <> :: NoteTrack -> NoteTrack -> NoteTrack
(<>)    (NoteTrack Track
notes1 Track
pitches1 Map Control Track
controls1)
            (NoteTrack Track
notes2 Track
pitches2 Map Control Track
controls2) =
        Track -> Track -> Map Control Track -> NoteTrack
NoteTrack (Track
notes1 forall a. Semigroup a => a -> a -> a
<> Track
notes2) (Track
pitches1 forall a. Semigroup a => a -> a -> a
<> Track
pitches2)
            (forall k a. (Ord k, Monoid a) => Map k a -> Map k a -> Map k a
Maps.mappend Map Control Track
controls1 Map Control Track
controls2)
instance Monoid NoteTrack where
    mempty :: NoteTrack
mempty = Track -> Track -> Map Control Track -> NoteTrack
NoteTrack forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
    mappend :: NoteTrack -> NoteTrack -> NoteTrack
mappend = forall a. Semigroup a => a -> a -> a
(<>)

-- | Take flat MIDI msgs to a list of tracks where events don't overlap, and
-- add pitch and control tracks.
convert_tracks :: [(Text, [Midi])]
    -> ([(Text, Track)], Skeleton.Skeleton, [Warn])
convert_tracks :: [(Text, [Midi])] -> ([(Text, Track)], Skeleton, [Text])
convert_tracks [(Text, [Midi])]
midi_tracks = (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Instrument, NoteTrack) -> [(Text, Track)]
convert [(Instrument, NoteTrack)]
tracks, Skeleton
skeleton, [Text]
warns)
    where
    ([(Instrument, NoteTrack)]
tracks, [Text]
warns) = forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (Text, [Midi]) -> ([(Instrument, NoteTrack)], [Text])
convert_track [(Text, [Midi])]
midi_tracks
    skeleton :: Skeleton
skeleton = [Edge] -> Skeleton
Skeleton.make forall a b. (a -> b) -> a -> b
$ [NoteTrack] -> [Edge]
note_track_edges forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Instrument, NoteTrack)]
tracks
    convert :: (Instrument, NoteTrack) -> [(Text, Track)]
convert (Instrument
inst, NoteTrack Track
notes Track
pitches Map Control Track
controls) =
        (Instrument -> Text
ParseTitle.instrument_to_title Instrument
inst, Track
notes)
        forall a. a -> [a] -> [a]
: (Text
"*", Track
pitches)
        forall a. a -> [a] -> [a]
: [(Typed Control -> Text
ParseTitle.control_to_title (forall a. a -> Typed a
ScoreT.untyped Control
control), Track
track)
            | (Control
control, Track
track) <- forall k a. Map k a -> [(k, a)]
Map.toAscList Map Control Track
controls]

note_track_edges :: [NoteTrack] -> [Skeleton.Edge]
note_track_edges :: [NoteTrack] -> [Edge]
note_track_edges = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat 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 Int -> NoteTrack -> (Int, [Edge])
edges Int
1
    -- The skeleton starts at 1, because it can't go on the 0th track.
    where
    edges :: Int -> NoteTrack -> (Int, [Edge])
edges Int
n (NoteTrack Track
_ Track
_ Map Control Track
controls) = (Int
end, forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
ns (forall a. Int -> [a] -> [a]
drop Int
1 [Int]
ns))
        where
        end :: Int
end = Int
n forall a. Num a => a -> a -> a
+ Int
2 forall a. Num a => a -> a -> a
+ forall k a. Map k a -> Int
Map.size Map Control Track
controls
        ns :: [Int]
ns = [Int
n .. Int
endforall a. Num a => a -> a -> a
-Int
1]

-- | Take flat MIDI msgs to a list of tracks where events don't overlap.
convert_track :: (Text, [Midi]) -> ([(ScoreT.Instrument, NoteTrack)], [Warn])
convert_track :: (Text, [Midi]) -> ([(Instrument, NoteTrack)], [Text])
convert_track (Text
title, [Midi]
msgs) = (forall a b. (a -> b) -> [a] -> [b]
map (Text -> Instrument
ScoreT.Instrument Text
title,) [NoteTrack]
tracks, [Text]
warns)
    where
    ([NoteTrack]
tracks, [(RealTime, Key)]
stuck_on) = [Midi] -> ([NoteTrack], [(RealTime, Key)])
split_track [Midi]
msgs
    warns :: [Text]
warns = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(RealTime, Key)]
stuck_on then []
        else [Text
title forall a. Semigroup a => a -> a -> a
<> Text
": omitted notes with no note-offs: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [(RealTime, Key)]
stuck_on]

-- ** infer_keyswitches

-- TODO incomplete.  I need to modify convert_tracks to take [AttrMidi].

type AttrMidi = (RealTime, Either Attrs.Attributes Midi.Message)
type KeyswitchMap = Map (Set Midi.Key) Attrs.Attributes

-- | Collect sounding keys, and each time look in the AttributeMap for the
-- current set.  If I find a match, emit the attributes as the current state.
-- If the pitch is any keyswitch, omit it from the output.
infer_keyswitches :: KeyswitchMap -> [Midi] -> [AttrMidi]
infer_keyswitches :: KeyswitchMap -> [Midi] -> [AttrMidi]
infer_keyswitches KeyswitchMap
ks_map = forall {t}.
Set Key -> [(t, Message)] -> [(t, Either Attributes Message)]
go forall a. Set a
Set.empty
    where
    go :: Set Key -> [(t, Message)] -> [(t, Either Attributes Message)]
go Set Key
_ [] = []
    go Set Key
old_held ((t
t, Message
msg) : [(t, Message)]
msgs) = case Message -> Maybe (Bool, Key)
note_key Message
msg of
        Just (Bool
True, Key
key) -> forall a b. (a -> b) -> [a] -> [b]
map (t
t,) (forall {b}. [Either Attributes b]
set_attrs forall a. [a] -> [a] -> [a]
++ forall {b} {a}. Key -> b -> [Either a b]
emit Key
key Message
msg) forall a. [a] -> [a] -> [a]
++ Set Key -> [(t, Message)] -> [(t, Either Attributes Message)]
go Set Key
held [(t, Message)]
msgs
            where
            held :: Set Key
held = forall a. Ord a => a -> Set a -> Set a
Set.insert Key
key Set Key
old_held
            set_attrs :: [Either Attributes b]
set_attrs = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Set Key
held KeyswitchMap
ks_map)
        Just (Bool
False, Key
key) -> forall a b. (a -> b) -> [a] -> [b]
map (t
t,) (forall {b} {a}. Key -> b -> [Either a b]
emit Key
key Message
msg) forall a. [a] -> [a] -> [a]
++ Set Key -> [(t, Message)] -> [(t, Either Attributes Message)]
go Set Key
held [(t, Message)]
msgs
            where held :: Set Key
held = forall a. Ord a => a -> Set a -> Set a
Set.delete Key
key Set Key
old_held
        Maybe (Bool, Key)
Nothing -> (t
t, forall a b. b -> Either a b
Right Message
msg) forall a. a -> [a] -> [a]
: Set Key -> [(t, Message)] -> [(t, Either Attributes Message)]
go Set Key
old_held [(t, Message)]
msgs
    emit :: Key -> b -> [Either a b]
emit Key
key b
msg = if forall a. Ord a => a -> Set a -> Bool
Set.member Key
key Set Key
keyswitches then [] else [forall a b. b -> Either a b
Right b
msg]
    keyswitches :: Set Key
keyswitches = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions (forall k a. Map k a -> [k]
Map.keys KeyswitchMap
ks_map)

note_key :: Midi.Message -> Maybe (Bool, Midi.Key)
note_key :: Message -> Maybe (Bool, Key)
note_key (Midi.ChannelMessage Word8
_ ChannelMessage
msg) = case ChannelMessage
msg of
    Midi.NoteOn Key
key Word8
_ -> forall a. a -> Maybe a
Just (Bool
True, Key
key)
    Midi.NoteOff Key
key Word8
_ -> forall a. a -> Maybe a
Just (Bool
False, Key
key)
    ChannelMessage
_ -> forall a. Maybe a
Nothing
note_key Message
_ = forall a. Maybe a
Nothing

keyswitch_map :: Patch.AttributeMap -> KeyswitchMap
keyswitch_map :: AttributeMap -> KeyswitchMap
keyswitch_map (Common.AttributeMap [(Attributes, ([Keyswitch], Maybe Keymap))]
amap) =
    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 a. Set a -> Bool
Set.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
        [(forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Keyswitch -> Maybe Key
key_of [Keyswitch]
ks), Attributes
attrs) | (Attributes
attrs, ([Keyswitch]
ks, Maybe Keymap
_)) <- [(Attributes, ([Keyswitch], Maybe Keymap))]
amap]
    where
    key_of :: Keyswitch -> Maybe Key
key_of (Patch.Keyswitch Key
k) = forall a. a -> Maybe a
Just Key
k
    key_of Keyswitch
_ = forall a. Maybe a
Nothing

-- ** split_track

-- | Keep a cache of the end of the last event, to make it easier to find
-- a free track.
type SplitState = IntMap (RealTime, NoteTrack)

-- | For each note, assign to the lowest track which doesn't have an overlap.
split_track :: [Midi] -> ([NoteTrack], [(RealTime, Midi.Key)])
    -- ^ (tracks, notes stuck on)
split_track :: [Midi] -> ([NoteTrack], [(RealTime, Key)])
split_track [Midi]
msgs = (forall {a} {b}. IntMap (a, b) -> [b]
extract forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SplitState
-> (RealTime, RealTime, Key, Word8, [MidiControl]) -> SplitState
collect forall a. IntMap a
IntMap.empty [(RealTime, RealTime, Key, Word8, [MidiControl])]
notes, [(RealTime, Key)]
stuck_on)
    where
    ([(RealTime, RealTime, Key, Word8, [MidiControl])]
notes, [(RealTime, Key)]
stuck_on) = [Midi]
-> ([(RealTime, RealTime, Key, Word8, [MidiControl])],
    [(RealTime, Key)])
collect_notes [Midi]
msgs
    extract :: IntMap (a, b) -> [b]
extract = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IntMap a -> [a]
IntMap.elems
    collect :: SplitState
-> (RealTime, RealTime, Key, Word8, [MidiControl]) -> SplitState
collect SplitState
state note :: (RealTime, RealTime, Key, Word8, [MidiControl])
note@(RealTime
start, RealTime
_, Key
_, Word8
_, [MidiControl]
_) =
        forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
tracknum ((RealTime, RealTime, Key, Word8, [MidiControl])
-> (RealTime, NoteTrack) -> (RealTime, NoteTrack)
insert_note (RealTime, RealTime, Key, Word8, [MidiControl])
note (RealTime, NoteTrack)
track) SplitState
state
        where (Int
tracknum, (RealTime, NoteTrack)
track) = RealTime -> SplitState -> (Int, (RealTime, NoteTrack))
find_non_overlapping RealTime
start SplitState
state

find_non_overlapping :: RealTime -> SplitState -> (Int, (RealTime, NoteTrack))
find_non_overlapping :: RealTime -> SplitState -> (Int, (RealTime, NoteTrack))
find_non_overlapping RealTime
start SplitState
state =
    forall a. a -> Maybe a -> a
fromMaybe (Int
0, (RealTime
0, forall a. Monoid a => a
mempty)) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((forall a. Ord a => a -> a -> Bool
<=RealTime
start) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Int, (RealTime, NoteTrack))]
tracks
    where
    tracks :: [(Int, (RealTime, NoteTrack))]
tracks = [(Int
n, forall a. a -> Maybe a -> a
fromMaybe (RealTime
0, forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$ forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
n SplitState
state) | Int
n <- [Int
0..]]

insert_note :: MidiNote -> (RealTime, NoteTrack) -> (RealTime, NoteTrack)
insert_note :: (RealTime, RealTime, Key, Word8, [MidiControl])
-> (RealTime, NoteTrack) -> (RealTime, NoteTrack)
insert_note (RealTime, RealTime, Key, Word8, [MidiControl])
note (RealTime
last, NoteTrack
note_track) =
    (forall a. Ord a => a -> a -> a
max RealTime
last ((RealTime, RealTime, Key, Word8, [MidiControl]) -> RealTime
note_last (RealTime, RealTime, Key, Word8, [MidiControl])
note), (RealTime, RealTime, Key, Word8, [MidiControl]) -> NoteTrack
note_to_track (RealTime, RealTime, Key, Word8, [MidiControl])
note forall a. Semigroup a => a -> a -> a
<> NoteTrack
note_track)

note_last :: MidiNote -> RealTime
note_last :: (RealTime, RealTime, Key, Word8, [MidiControl]) -> RealTime
note_last (RealTime
_, RealTime
end, Key
_, Word8
_, [MidiControl]
controls) = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ RealTime
end forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [MidiControl]
controls

note_to_track :: MidiNote -> NoteTrack
note_to_track :: (RealTime, RealTime, Key, Word8, [MidiControl]) -> NoteTrack
note_to_track (RealTime
start, RealTime
end, Key
key, Word8
vel, [MidiControl]
controls) =
    Track -> Track -> Map Control Track -> NoteTrack
NoteTrack (forall k a. k -> a -> Map k a
Map.singleton (RealTime -> ScoreTime
score RealTime
start) (RealTime -> ScoreTime
score (RealTime
end forall a. Num a => a -> a -> a
- RealTime
start), Text
""))
        (forall k a. k -> a -> Map k a
Map.singleton (RealTime -> ScoreTime
score RealTime
start) (ScoreTime
0, Key -> Text
key_to_pitch Key
key))
        (Map Control Track
dyn forall a. Semigroup a => a -> a -> a
<> [MidiControl] -> Map Control Track
convert_controls [MidiControl]
controls)
    where
    dyn :: Map Control Track
dyn = forall k a. k -> a -> Map k a
Map.singleton Control
Controls.dynamic
        (forall k a. k -> a -> Map k a
Map.singleton (RealTime -> ScoreTime
score RealTime
start) (ScoreTime
0, Word8 -> Text
show_val Word8
vel))
    score :: RealTime -> ScoreTime
score = RealTime -> ScoreTime
RealTime.to_score

convert_controls :: [MidiControl] -> Map ScoreT.Control Track
convert_controls :: [MidiControl] -> Map Control Track
convert_controls [MidiControl]
cs =
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word8 -> Control
cc_to_control Word8
cc, forall {a} {a}.
Num a =>
[(RealTime, (a, Word8))] -> Map ScoreTime (a, Text)
convert [MidiControl]
msgs)
        | (Word8
cc, [MidiControl]
msgs) <- forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])]
Lists.keyedGroupSort (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [MidiControl]
cs]
    where
    convert :: [(RealTime, (a, Word8))] -> Map ScoreTime (a, Text)
convert [(RealTime, (a, Word8))]
midi_controls =
        forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RealTime -> ScoreTime
RealTime.to_score RealTime
start, (a
0, Word8 -> Text
show_val Word8
val))
            | (RealTime
start, (a
_, Word8
val)) <- [(RealTime, (a, Word8))]
midi_controls]

key_to_pitch :: Midi.Key -> Text
key_to_pitch :: Key -> Text
key_to_pitch = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"?" Note -> Text
Pitch.note_text forall b c a. (b -> c) -> (a -> b) -> a -> c
. NoteNumber -> Maybe Note
Twelve.show_nn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Key -> a
Midi.from_key

-- | This is the same as 'Cmd.InputNote.cc_to_control', but I don't want the
-- dependency.
cc_to_control :: Midi.Control -> ScoreT.Control
cc_to_control :: Word8 -> Control
cc_to_control Word8
cc =
    forall a. a -> Maybe a -> a
fromMaybe (Text -> Control
ScoreT.Control (Text
"cc" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Word8
cc)) (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word8
cc Map Word8 Control
cc_control)
    where
    cc_control :: Map Word8 Control
cc_control = forall a k. Ord a => Map k a -> Map a k
Maps.invert ControlMap
Control.universal_control_map

show_val :: Word.Word8 -> Text -- the Midi types are aliases for Word8
show_val :: Word8 -> Text
show_val Word8
val = Double -> Text
ShowVal.show_hex_val forall a b. (a -> b) -> a -> b
$ Double
d forall a. Fractional a => a -> a -> a
/ Double
0x7f
    where
    d :: Double
    d :: Double
d = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
val

-- ** collect_notes

-- | (start, end, key, vel, controls)
type MidiNote = (RealTime, RealTime, Midi.Key, Midi.Velocity, [MidiControl])
type MidiControl = (RealTime, (Midi.Control, Midi.ControlValue))

-- for each (note-on -- note-off) collect the controls in its scope
collect_notes :: [Midi] -> ([MidiNote], [(RealTime, Midi.Key)])
collect_notes :: [Midi]
-> ([(RealTime, RealTime, Key, Word8, [MidiControl])],
    [(RealTime, Key)])
collect_notes [Midi]
msgs = (forall a. [Maybe a] -> [a]
Maybe.catMaybes [Maybe (RealTime, RealTime, Key, Word8, [MidiControl])]
notes, 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 b. (a, b) -> a
fst) [(RealTime, (Key, Word8))]
stuck_on)
    where
    (([MidiControl]
_, [(RealTime, (Key, Word8))]
stuck_on), [Maybe (RealTime, RealTime, Key, Word8, [MidiControl])]
notes) = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL forall {b}.
Ord b =>
([(b, (Word8, Word8))], [(b, (Key, Word8))])
-> (b, Message)
-> (([(b, (Word8, Word8))], [(b, (Key, Word8))]),
    Maybe (b, b, Key, Word8, [(b, (Word8, Word8))]))
go ([], []) [Midi]
msgs
    go :: ([(b, (Word8, Word8))], [(b, (Key, Word8))])
-> (b, Message)
-> (([(b, (Word8, Word8))], [(b, (Key, Word8))]),
    Maybe (b, b, Key, Word8, [(b, (Word8, Word8))]))
go ([(b, (Word8, Word8))]
controls, [(b, (Key, Word8))]
note_ons) (b
time, Midi.ChannelMessage Word8
_ ChannelMessage
msg) = case ChannelMessage
msg of
        Midi.ControlChange Word8
cc Word8
val ->
            (((b
time, (Word8
cc, Word8
val)) forall a. a -> [a] -> [a]
: [(b, (Word8, Word8))]
controls, [(b, (Key, Word8))]
note_ons), forall a. Maybe a
Nothing)
        Midi.NoteOn Key
key Word8
vel ->
            (([(b, (Word8, Word8))]
controls, (b
time, (Key
key, Word8
vel)) forall a. a -> [a] -> [a]
: [(b, (Key, Word8))]
note_ons), forall a. Maybe a
Nothing)
        Midi.NoteOff Key
key Word8
_ ->
            case forall a. (a -> Bool) -> [a] -> Maybe (a, [a])
find_remove ((forall a. Eq a => a -> a -> Bool
==Key
key) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(b, (Key, Word8))]
note_ons of
                Maybe ((b, (Key, Word8)), [(b, (Key, Word8))])
Nothing -> (([(b, (Word8, Word8))]
controls, [(b, (Key, Word8))]
note_ons), forall a. Maybe a
Nothing)
                Just ((b
start, (Key
_, Word8
vel)), [(b, (Key, Word8))]
note_ons) -> (([(b, (Word8, Word8))]
controls, [(b, (Key, Word8))]
note_ons),
                    forall a. a -> Maybe a
Just (forall {b} {b} {c} {d} {b}.
Ord b =>
b -> b -> c -> d -> [(b, b)] -> (b, b, c, d, [(b, b)])
collect_note b
start b
time Key
key Word8
vel [(b, (Word8, Word8))]
controls))
        ChannelMessage
_ -> (([(b, (Word8, Word8))]
controls, [(b, (Key, Word8))]
note_ons), forall a. Maybe a
Nothing)
    go ([(b, (Word8, Word8))], [(b, (Key, Word8))])
state (b, Message)
_ = (([(b, (Word8, Word8))], [(b, (Key, Word8))])
state, forall a. Maybe a
Nothing)
    collect_note :: b -> b -> c -> d -> [(b, b)] -> (b, b, c, d, [(b, b)])
collect_note b
start b
end c
key d
vel [(b, b)]
controls =
        (b
start, b
end, c
key, d
vel, forall a. [a] -> [a]
reverse (forall a. (a -> Bool) -> [a] -> [a]
takeWhile ((forall a. Ord a => a -> a -> Bool
>=b
start) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(b, b)]
controls))

-- | Like 'List.find', but also return the list with the found element
-- removed.
find_remove :: (a -> Bool) -> [a] -> Maybe (a, [a])
find_remove :: forall a. (a -> Bool) -> [a] -> Maybe (a, [a])
find_remove a -> Bool
f [a]
xs = case [a] -> (Maybe a, [a])
go [a]
xs of
        (Maybe a
Nothing, [a]
_) -> forall a. Maybe a
Nothing
        (Just a
x, [a]
xs) -> forall a. a -> Maybe a
Just (a
x, [a]
xs)
    where
    go :: [a] -> (Maybe a, [a])
go [] = (forall a. Maybe a
Nothing, [])
    go (a
x:[a]
xs)
        | a -> Bool
f a
x = (forall a. a -> Maybe a
Just a
x, [a]
xs)
        | Bool
otherwise = let (Maybe a
found, [a]
rest) = [a] -> (Maybe a, [a])
go [a]
xs in (Maybe a
found, a
x forall a. a -> [a] -> [a]
: [a]
rest)