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

{-
Maybe we could use StorableVector.Pattern.LazySize
or we could use synthesizer-core/ChunkySize.
What package should we rely on?
Which one is more portable?

We do not use this type for timing in event lists anymore.
It worked in principle but left us with a couple of memory leaks,
that I could never identify and eliminate completely.
-}
type LazyTime = NonNegChunky.T NonNegW.Integer



-- * event filters

type Filter event = State (EventList.T StrictTime [event])



{- |
We turn the strict time values into lazy ones
according to the breaks by our beat.
However for the laziness breaks we ignore the events that are filtered out.
That is we loose laziness granularity
but hopefully gain efficiency by larger blocks.
-}
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)

{-
getControllerEvents ::
   (Check.C event) =>
   Channel -> Controller ->
   Filter event (EventList.T StrictTime (Maybe Int))
getControllerEvents chan ctrl =
   fmap (fmap (fmap snd . ListHT.viewR)) $
   getSlice (Check.controller chan 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

{-
We could also provide a function which filters for specific programs/presets.
-}
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]
:
   {-
   We do not handle AllSoundOff here,
   since this would also mean to clear reverb buffers
   and this cannot be handled here.
   -}
   (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 =
   -- evaluate program for every event in order to prevent a space leak
   (\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 Char.isUpper ("a" ./ 3 /. "bf" ./ 5 /. "aCcd" ./ empty :: Data.EventList.Relative.BodyBody.T StrictTime [Char])
-}
{- |
Search for specific event,
return its time stamp and remove it.
-}
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


-- ToDo: move to somewhere else, this has nothing todo with event lists

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