{-# LANGUAGE NoImplicitPrelude #-}
module Synthesizer.MIDI.EventList where
import qualified Sound.MIDI.Message.Class.Check as Check
import qualified Sound.MIDI.Message.Channel as ChannelMsg
import qualified Sound.MIDI.Message.Channel.Mode as Mode
import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Data.EventList.Relative.MixedBody as EventListMB
import qualified Data.EventList.Relative.BodyBody as EventListBB
import Control.Monad.Trans.State
(State, state, evalState, gets, put, )
import Data.Traversable (traverse, )
import qualified Numeric.NonNegative.Class as NonNeg
import qualified Numeric.NonNegative.Wrapper as NonNegW
import qualified Numeric.NonNegative.Chunky as NonNegChunky
import Data.Array (Array, listArray, (!), bounds, inRange, )
import qualified Data.List.HT as ListHT
import Data.Tuple.HT (mapPair, mapFst, mapSnd, )
import Data.Maybe.HT (toMaybe, )
import Data.Maybe (catMaybes, isNothing, )
import Control.Monad.HT ((<=<), )
import Control.Monad (guard, msum, )
import NumericPrelude.Numeric
import NumericPrelude.Base
type StrictTime = NonNegW.Integer
type LazyTime = NonNegChunky.T NonNegW.Integer
type Filter event = State (EventList.T StrictTime [event])
getSlice ::
(event -> Maybe a) ->
Filter event (EventList.T StrictTime [a])
getSlice :: forall event a.
(event -> Maybe a) -> Filter event (T StrictTime [a])
getSlice event -> Maybe a
f =
forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state forall a b. (a -> b) -> a -> b
$
forall time body0 body1.
T time (body0, body1) -> (T time body0, T time body1)
EventList.unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> Maybe b) -> [a] -> ([b], [a])
ListHT.partitionMaybe event -> Maybe a
f)
type Channel = ChannelMsg.Channel
type Controller = ChannelMsg.Controller
type Pitch = ChannelMsg.Pitch
type Velocity = ChannelMsg.Velocity
type Program = ChannelMsg.Program
getControllerEvents ::
(Check.C event) =>
Channel -> Controller ->
Filter event (EventList.T StrictTime [Int])
getControllerEvents :: forall event.
C event =>
Channel -> Controller -> Filter event (T StrictTime [Int])
getControllerEvents Channel
chan Controller
ctrl =
forall event a.
(event -> Maybe a) -> Filter event (T StrictTime [a])
getSlice (forall event.
C event =>
Channel -> Controller -> event -> Maybe Int
Check.controller Channel
chan Controller
ctrl)
data NoteBoundary a =
NoteBoundary Pitch Velocity a
| AllNotesOff
deriving (NoteBoundary a -> NoteBoundary a -> Bool
forall a. Eq a => NoteBoundary a -> NoteBoundary a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoteBoundary a -> NoteBoundary a -> Bool
$c/= :: forall a. Eq a => NoteBoundary a -> NoteBoundary a -> Bool
== :: NoteBoundary a -> NoteBoundary a -> Bool
$c== :: forall a. Eq a => NoteBoundary a -> NoteBoundary a -> Bool
Eq, Int -> NoteBoundary a -> ShowS
forall a. Show a => Int -> NoteBoundary a -> ShowS
forall a. Show a => [NoteBoundary a] -> ShowS
forall a. Show a => NoteBoundary a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoteBoundary a] -> ShowS
$cshowList :: forall a. Show a => [NoteBoundary a] -> ShowS
show :: NoteBoundary a -> String
$cshow :: forall a. Show a => NoteBoundary a -> String
showsPrec :: Int -> NoteBoundary a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> NoteBoundary a -> ShowS
Show)
data Note = Note Program Pitch Velocity LazyTime
deriving (Note -> Note -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Note -> Note -> Bool
$c/= :: Note -> Note -> Bool
== :: Note -> Note -> Bool
$c== :: Note -> Note -> Bool
Eq, Int -> Note -> ShowS
[Note] -> ShowS
Note -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Note] -> ShowS
$cshowList :: [Note] -> ShowS
show :: Note -> String
$cshow :: Note -> String
showsPrec :: Int -> Note -> ShowS
$cshowsPrec :: Int -> Note -> ShowS
Show)
case_ :: Maybe a -> (a -> b) -> Maybe b
case_ :: forall a b. Maybe a -> (a -> b) -> Maybe b
case_ = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
getNoteEvents ::
(Check.C event) =>
Channel ->
Filter event (EventList.T StrictTime [Either Program (NoteBoundary Bool)])
getNoteEvents :: forall event.
C event =>
Channel
-> Filter event (T StrictTime [Either Program (NoteBoundary Bool)])
getNoteEvents Channel
chan =
forall event a.
(event -> Maybe a) -> Filter event (T StrictTime [a])
getSlice forall a b. (a -> b) -> a -> b
$ forall event.
C event =>
Channel -> event -> Maybe (Either Program (NoteBoundary Bool))
checkNoteEvent Channel
chan
checkNoteEvent ::
(Check.C event) =>
Channel -> event ->
Maybe (Either Program (NoteBoundary Bool))
checkNoteEvent :: forall event.
C event =>
Channel -> event -> Maybe (Either Program (NoteBoundary Bool))
checkNoteEvent Channel
chan event
e = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall a b. (a -> b) -> a -> b
$
forall a b. Maybe a -> (a -> b) -> Maybe b
case_ (forall event.
C event =>
Channel -> event -> Maybe (Velocity, Pitch, Bool)
Check.noteExplicitOff Channel
chan event
e) (\(Velocity
velocity, Pitch
pitch, Bool
press) ->
forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. Pitch -> Velocity -> a -> NoteBoundary a
NoteBoundary Pitch
pitch Velocity
velocity Bool
press) forall a. a -> [a] -> [a]
:
forall a b. Maybe a -> (a -> b) -> Maybe b
case_ (forall event. C event => Channel -> event -> Maybe Program
Check.program Channel
chan event
e) forall a b. a -> Either a b
Left forall a. a -> [a] -> [a]
:
(forall event. C event => Channel -> event -> Maybe T
Check.mode Channel
chan event
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \T
mode -> do
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (T
mode forall a. Eq a => a -> a -> Bool
== T
Mode.AllNotesOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right forall a. NoteBoundary a
AllNotesOff)) forall a. a -> [a] -> [a]
:
[]
embedPrograms ::
Program ->
EventList.T StrictTime [Either Program (NoteBoundary Bool)] ->
EventList.T StrictTime [NoteBoundary (Maybe Program)]
embedPrograms :: Program
-> T StrictTime [Either Program (NoteBoundary Bool)]
-> T StrictTime [NoteBoundary (Maybe Program)]
embedPrograms Program
initPgm =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState Program
initPgm forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Either Program (NoteBoundary Bool)
-> State Program (Maybe (NoteBoundary (Maybe Program)))
embedProgramState)
embedProgramState ::
Either Program (NoteBoundary Bool) ->
State Program (Maybe (NoteBoundary (Maybe Program)))
embedProgramState :: Either Program (NoteBoundary Bool)
-> State Program (Maybe (NoteBoundary (Maybe Program)))
embedProgramState =
(\Maybe (NoteBoundary (Maybe Program))
n -> forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state (\Program
s -> (seq :: forall a b. a -> b -> b
seq Program
s Maybe (NoteBoundary (Maybe Program))
n, Program
s)))
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=<
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(\Program
pgm -> forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put Program
pgm forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
(\NoteBoundary Bool
bnd ->
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
.
case NoteBoundary Bool
bnd of
NoteBoundary Bool
AllNotesOff -> forall a b. a -> b -> a
const forall a. NoteBoundary a
AllNotesOff
NoteBoundary Pitch
p Velocity
v Bool
press ->
forall a. Pitch -> Velocity -> a -> NoteBoundary a
NoteBoundary Pitch
p Velocity
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bool -> a -> Maybe a
toMaybe Bool
press))
matchNoteEvents ::
EventList.T StrictTime [NoteBoundary (Maybe Program)] ->
EventList.T StrictTime [Note]
matchNoteEvents :: T StrictTime [NoteBoundary (Maybe Program)] -> T StrictTime [Note]
matchNoteEvents =
forall noteBnd.
(noteBnd -> Maybe (noteBnd -> Bool, LazyTime -> Note))
-> T StrictTime [noteBnd] -> T StrictTime [Note]
matchNoteEventsCore forall a b. (a -> b) -> a -> b
$ \NoteBoundary (Maybe Program)
bndOn -> case NoteBoundary (Maybe Program)
bndOn of
NoteBoundary (Maybe Program)
AllNotesOff -> forall a. Maybe a
Nothing
NoteBoundary Pitch
pitchOn Velocity
velOn Maybe Program
pressOn ->
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe Program
pressOn forall a b. (a -> b) -> a -> b
$ \Program
pgm ->
(\NoteBoundary (Maybe Program)
bndOff ->
case NoteBoundary (Maybe Program)
bndOff of
NoteBoundary (Maybe Program)
AllNotesOff -> Bool
True
NoteBoundary Pitch
pitchOff Velocity
_velOff Maybe Program
pressOff ->
Pitch
pitchOn forall a. Eq a => a -> a -> Bool
== Pitch
pitchOff Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe Program
pressOff,
Program -> Pitch -> Velocity -> LazyTime -> Note
Note Program
pgm Pitch
pitchOn Velocity
velOn)
matchNoteEventsCore ::
(noteBnd ->
Maybe (noteBnd -> Bool, LazyTime -> Note)) ->
EventList.T StrictTime [noteBnd] ->
EventList.T StrictTime [Note]
matchNoteEventsCore :: forall noteBnd.
(noteBnd -> Maybe (noteBnd -> Bool, LazyTime -> Note))
-> T StrictTime [noteBnd] -> T StrictTime [Note]
matchNoteEventsCore noteBnd -> Maybe (noteBnd -> Bool, LazyTime -> Note)
methods =
let recourseEvents :: T StrictTime [noteBnd] -> ([Note], T StrictTime [noteBnd])
recourseEvents =
forall body time a. (body -> T time body -> a) -> T time body -> a
EventListMB.switchBodyL forall a b. (a -> b) -> a -> b
$ \[noteBnd]
evs0 T StrictTime [noteBnd]
xs0 -> case [noteBnd]
evs0 of
[] -> ([], T StrictTime [noteBnd]
xs0)
noteBnd
ev:[noteBnd]
evs ->
case noteBnd -> Maybe (noteBnd -> Bool, LazyTime -> Note)
methods noteBnd
ev of
Maybe (noteBnd -> Bool, LazyTime -> Note)
Nothing ->
T StrictTime [noteBnd] -> ([Note], T StrictTime [noteBnd])
recourseEvents (forall body time. body -> T time body -> T time body
EventListMB.consBody [noteBnd]
evs T StrictTime [noteBnd]
xs0)
Just (noteBnd -> Bool
check, LazyTime -> Note
cons) ->
case forall time body.
C time =>
(body -> Bool) -> T time [body] -> (T time, T time [body])
durationRemove noteBnd -> Bool
check (forall body time. body -> T time body -> T time body
EventListMB.consBody [noteBnd]
evs T StrictTime [noteBnd]
xs0) of
(LazyTime
dur, T StrictTime [noteBnd]
xs1) ->
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst
(LazyTime -> Note
cons LazyTime
dur forall a. a -> [a] -> [a]
:)
(T StrictTime [noteBnd] -> ([Note], T StrictTime [noteBnd])
recourseEvents T StrictTime [noteBnd]
xs1)
recourse :: T StrictTime [noteBnd] -> T StrictTime [Note]
recourse =
forall c time body.
c -> ((time, body) -> T time body -> c) -> T time body -> c
EventList.switchL forall time body. T time body
EventList.empty forall a b. (a -> b) -> a -> b
$ \(StrictTime
t,[noteBnd]
evs0) T StrictTime [noteBnd]
xs0 ->
let ([Note]
evs1,T StrictTime [noteBnd]
xs1) = T StrictTime [noteBnd] -> ([Note], T StrictTime [noteBnd])
recourseEvents (forall body time. body -> T time body -> T time body
EventListMB.consBody [noteBnd]
evs0 T StrictTime [noteBnd]
xs0)
in forall time body. time -> body -> T time body -> T time body
EventList.cons StrictTime
t [Note]
evs1 forall a b. (a -> b) -> a -> b
$ T StrictTime [noteBnd] -> T StrictTime [Note]
recourse T StrictTime [noteBnd]
xs1
in T StrictTime [noteBnd] -> T StrictTime [Note]
recourse
durationRemove ::
(NonNeg.C time) =>
(body -> Bool) ->
EventListBB.T time [body] ->
(NonNegChunky.T time, EventListBB.T time [body])
durationRemove :: forall time body.
C time =>
(body -> Bool) -> T time [body] -> (T time, T time [body])
durationRemove body -> Bool
p =
let errorEndOfList :: (a, b)
errorEndOfList =
(forall a. HasCallStack => String -> a
error String
"no matching body element found",
forall a. HasCallStack => String -> a
error String
"list ended before matching element found")
recourse :: T time [body] -> (T time, T time [body])
recourse =
forall body time a. (body -> T time body -> a) -> T time body -> a
EventListMB.switchBodyL forall a b. (a -> b) -> a -> b
$ \[body]
evs T time [body]
xs0 ->
let ([body]
prefix, [body]
suffix0) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break body -> Bool
p [body]
evs
([body]
suffix1, (T time, T time [body])
rest) =
case [body]
suffix0 of
[] -> ([],
forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a time body.
a -> (time -> T time body -> a) -> T time body -> a
EventListMB.switchTimeL forall {a} {b}. (a, b)
errorEndOfList) T time [body]
xs0 forall a b. (a -> b) -> a -> b
$ \time
t T time [body]
xs1 ->
forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair
(forall a. C a => [a] -> T a
NonNegChunky.fromChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. (time
tforall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. T a -> [a]
NonNegChunky.toChunks,
forall time body. time -> T time body -> T time body
EventListMB.consTime time
t) forall a b. (a -> b) -> a -> b
$
T time [body] -> (T time, T time [body])
recourse T time [body]
xs1)
body
_:[body]
ys -> ([body]
ys, (forall a. C a => a
NonNeg.zero, T time [body]
xs0))
in forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd
(forall body time. body -> T time body -> T time body
EventListMB.consBody ([body]
prefixforall a. [a] -> [a] -> [a]
++[body]
suffix1))
(T time, T time [body])
rest
in T time [body] -> (T time, T time [body])
recourse
durationRemoveTB ::
(NonNeg.C time) =>
(body -> Bool) ->
EventList.T time [body] ->
(NonNegChunky.T time, EventList.T time [body])
durationRemoveTB :: forall time body.
C time =>
(body -> Bool) -> T time [body] -> (T time, T time [body])
durationRemoveTB body -> Bool
p =
let errorEndOfList :: (a, b)
errorEndOfList =
(forall a. HasCallStack => String -> a
error String
"no matching body element found",
forall a. HasCallStack => String -> a
error String
"list ended before matching element found")
recourse :: T time [body] -> (T time, T time [body])
recourse =
forall c time body.
c -> ((time, body) -> T time body -> c) -> T time body -> c
EventList.switchL forall {a} {b}. (a, b)
errorEndOfList forall a b. (a -> b) -> a -> b
$ \(time
t,[body]
evs) T time [body]
xs ->
let ([body]
prefix, [body]
suffix0) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break body -> Bool
p [body]
evs
([body]
suffix1, (T time, T time [body])
rest) =
case [body]
suffix0 of
[] -> ([], T time [body] -> (T time, T time [body])
recourse T time [body]
xs)
body
_:[body]
ys -> ([body]
ys, (forall a. C a => a
NonNeg.zero, T time [body]
xs))
in forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair
(forall a. C a => [a] -> T a
NonNegChunky.fromChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. (time
tforall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. T a -> [a]
NonNegChunky.toChunks,
forall time body. time -> body -> T time body -> T time body
EventList.cons time
t ([body]
prefixforall a. [a] -> [a] -> [a]
++[body]
suffix1))
(T time, T time [body])
rest
in T time [body] -> (T time, T time [body])
recourse
makeInstrumentArray :: [instr] -> Array Program instr
makeInstrumentArray :: forall instr. [instr] -> Array Program instr
makeInstrumentArray [instr]
instrs =
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray
(Int -> Program
ChannelMsg.toProgram Int
0, Int -> Program
ChannelMsg.toProgram (forall (t :: * -> *) a. Foldable t => t a -> Int
length [instr]
instrs forall a. C a => a -> a -> a
- Int
1))
[instr]
instrs
getInstrumentFromArray :: Array Program instr -> Program -> Program -> instr
getInstrumentFromArray :: forall instr. Array Program instr -> Program -> Program -> instr
getInstrumentFromArray Array Program instr
bank Program
defltPgm Program
pgm =
Array Program instr
bank forall i e. Ix i => Array i e -> i -> e
!
if forall a. Ix a => (a, a) -> a -> Bool
inRange (forall i e. Array i e -> (i, i)
bounds Array Program instr
bank) Program
pgm
then Program
pgm else Program
defltPgm