module Midi (
Time,
Velocity,
Program,
Controller,
Chan,
Event(Wait, Say, Event),
Channel(Channel),
Message(PgmChange, Controller, On, Off),
note, noteOn, noteOff,
rest,
program,
controller,
channel,
transpose, transposeEvent,
changeTempo, changeTempoEvent,
controlCurve,
normalVelocity,
emphasize,
takeTime,
dropTime,
skipTime,
compressTime,
lazyPause,
duration,
(+:+),
merge, (=:=),
mergeWait,
mergeMany,
) where
import Function
import Bool ( ifThenElse )
type Pitch = Integer ;
type Time = Integer ;
type Velocity = Integer ;
type Program = Integer ;
type Controller = Integer ;
type Chan = Integer ;
data Event a = Wait Time | Say String | Event a ;
data Channel a = Channel Integer a ;
data Message =
PgmChange Program
| Controller Controller Integer
| On Pitch Velocity
| Off Pitch Velocity ;
note :: Time -> Pitch -> [Event Message] ;
note :: Velocity -> Velocity -> [Event Message]
note Velocity
dur = (Velocity -> [Event Message]) -> Velocity -> [Event Message]
forall a. (Velocity -> a) -> Velocity -> a
applyStrict (Velocity -> Velocity -> [Event Message]
noteLazy Velocity
dur) ;
noteLazy :: Time -> Pitch -> [Event Message] ;
noteLazy :: Velocity -> Velocity -> [Event Message]
noteLazy Velocity
dur Velocity
pitch =
[ Velocity -> Event Message
noteOn Velocity
pitch
, Velocity -> Event Message
forall a. Velocity -> Event a
Wait Velocity
dur
, Velocity -> Event Message
noteOff Velocity
pitch
] ;
noteOn, noteOff :: Pitch -> Event Message ;
noteOn :: Velocity -> Event Message
noteOn Velocity
pitch = Message -> Event Message
forall a. a -> Event a
Event (Velocity -> Velocity -> Message
On Velocity
pitch Velocity
normalVelocity) ;
noteOff :: Velocity -> Event Message
noteOff Velocity
pitch = Message -> Event Message
forall a. a -> Event a
Event (Velocity -> Velocity -> Message
Off Velocity
pitch Velocity
normalVelocity) ;
rest :: Time -> [Event a] ;
rest :: forall a. Velocity -> [Event a]
rest Velocity
dur =
[ Velocity -> Event a
forall a. Velocity -> Event a
Wait Velocity
dur ] ;
program :: Program -> [Event Message] ;
program :: Velocity -> [Event Message]
program Velocity
n =
[ Message -> Event Message
forall a. a -> Event a
Event ( Velocity -> Message
PgmChange Velocity
n ) ] ;
controller :: Controller -> Integer -> [Event Message] ;
controller :: Velocity -> Velocity -> [Event Message]
controller Velocity
cc Velocity
x =
[ Message -> Event Message
forall a. a -> Event a
Event ( Velocity -> Velocity -> Message
Controller Velocity
cc Velocity
x ) ] ;
channel :: Chan -> [Event a] -> [Event (Channel a)] ;
channel :: forall a. Velocity -> [Event a] -> [Event (Channel a)]
channel Velocity
chan = (Event a -> Event (Channel a)) -> [Event a] -> [Event (Channel a)]
forall a b. (a -> b) -> [a] -> [b]
map ( Velocity -> Event a -> Event (Channel a)
forall a. Velocity -> Event a -> Event (Channel a)
channelEvent Velocity
chan ) ;
channelEvent :: Chan -> Event a -> Event (Channel a) ;
channelEvent :: forall a. Velocity -> Event a -> Event (Channel a)
channelEvent Velocity
chan (Event a
event) = Channel a -> Event (Channel a)
forall a. a -> Event a
Event (Velocity -> a -> Channel a
forall a. Velocity -> a -> Channel a
Channel Velocity
chan a
event) ;
channelEvent Velocity
_chan (Wait Velocity
dur) = Velocity -> Event (Channel a)
forall a. Velocity -> Event a
Wait Velocity
dur ;
channelEvent Velocity
_chan (Say String
text) = String -> Event (Channel a)
forall a. String -> Event a
Say String
text ;
transpose :: Integer -> [Event Message] -> [Event Message] ;
transpose :: Velocity -> [Event Message] -> [Event Message]
transpose Velocity
d = (Event Message -> Event Message)
-> [Event Message] -> [Event Message]
forall a b. (a -> b) -> [a] -> [b]
map ( Velocity -> Event Message -> Event Message
transposeEvent Velocity
d ) ;
transposeEvent :: Integer -> Event Message -> Event Message ;
transposeEvent :: Velocity -> Event Message -> Event Message
transposeEvent Velocity
d (Event (On Velocity
pitch Velocity
velocity)) = Message -> Event Message
forall a. a -> Event a
Event (Velocity -> Velocity -> Message
On (Velocity
pitchVelocity -> Velocity -> Velocity
forall a. Num a => a -> a -> a
+Velocity
d) Velocity
velocity) ;
transposeEvent Velocity
d (Event (Off Velocity
pitch Velocity
velocity)) = Message -> Event Message
forall a. a -> Event a
Event (Velocity -> Velocity -> Message
Off (Velocity
pitchVelocity -> Velocity -> Velocity
forall a. Num a => a -> a -> a
+Velocity
d) Velocity
velocity) ;
transposeEvent Velocity
_d Event Message
event = Event Message
event ;
changeTempo :: Integer -> [Event a] -> [Event a] ;
changeTempo :: forall a. Velocity -> [Event a] -> [Event a]
changeTempo Velocity
d = (Event a -> Event a) -> [Event a] -> [Event a]
forall a b. (a -> b) -> [a] -> [b]
map ( Velocity -> Event a -> Event a
forall a. Velocity -> Event a -> Event a
changeTempoEvent Velocity
d ) ;
changeTempoEvent :: Integer -> Event a -> Event a ;
changeTempoEvent :: forall a. Velocity -> Event a -> Event a
changeTempoEvent Velocity
c (Wait Velocity
d) = Velocity -> Event a
forall a. Velocity -> Event a
Wait (Velocity
cVelocity -> Velocity -> Velocity
forall a. Num a => a -> a -> a
*Velocity
d) ;
changeTempoEvent Velocity
_c Event a
event = Event a
event ;
controlCurve :: Time -> Controller -> [Integer] -> [Event Message] ;
controlCurve :: Velocity -> Velocity -> [Velocity] -> [Event Message]
controlCurve Velocity
_d Velocity
_cc [] = [] ;
controlCurve Velocity
d Velocity
cc (Velocity
x : [Velocity]
xs) =
Message -> Event Message
forall a. a -> Event a
Event (Velocity -> Velocity -> Message
Controller Velocity
cc Velocity
x) Event Message -> [Event Message] -> [Event Message]
forall a. a -> [a] -> [a]
: Velocity -> Event Message
forall a. Velocity -> Event a
Wait Velocity
d Event Message -> [Event Message] -> [Event Message]
forall a. a -> [a] -> [a]
: Velocity -> Velocity -> [Velocity] -> [Event Message]
controlCurve Velocity
d Velocity
cc [Velocity]
xs ;
normalVelocity :: Velocity ;
normalVelocity :: Velocity
normalVelocity = Velocity
64 ;
emphasize :: Integer -> [Event Message] -> [Event Message] ;
emphasize :: Velocity -> [Event Message] -> [Event Message]
emphasize Velocity
v = (Event Message -> Event Message)
-> [Event Message] -> [Event Message]
forall a b. (a -> b) -> [a] -> [b]
map ( Velocity -> Event Message -> Event Message
emphasizeEvent Velocity
v ) ;
emphasizeEvent :: Integer -> Event Message -> Event Message ;
emphasizeEvent :: Velocity -> Event Message -> Event Message
emphasizeEvent Velocity
v (Event (On Velocity
pitch Velocity
velocity)) = Message -> Event Message
forall a. a -> Event a
Event (Velocity -> Velocity -> Message
On Velocity
pitch (Velocity
velocityVelocity -> Velocity -> Velocity
forall a. Num a => a -> a -> a
+Velocity
v)) ;
emphasizeEvent Velocity
_v Event Message
event = Event Message
event ;
takeTime :: Time -> [Event a] -> [Event a] ;
takeTime :: forall a. Velocity -> [Event a] -> [Event a]
takeTime Velocity
_ [] = [] ;
takeTime Velocity
t ( Wait Velocity
x : [Event a]
xs ) =
Bool -> [Event a] -> [Event a] -> [Event a]
forall a. Bool -> a -> a -> a
ifThenElse (Velocity
tVelocity -> Velocity -> Bool
forall a. Ord a => a -> a -> Bool
<Velocity
x)
[ Velocity -> Event a
forall a. Velocity -> Event a
Wait Velocity
t ]
( Velocity -> Event a
forall a. Velocity -> Event a
Wait Velocity
x Event a -> [Event a] -> [Event a]
forall a. a -> [a] -> [a]
: (Velocity -> [Event a] -> [Event a])
-> Velocity -> [Event a] -> [Event a]
forall a. (Velocity -> a) -> Velocity -> a
applyStrict Velocity -> [Event a] -> [Event a]
forall a. Velocity -> [Event a] -> [Event a]
takeTime (Velocity
tVelocity -> Velocity -> Velocity
forall a. Num a => a -> a -> a
-Velocity
x) [Event a]
xs ) ;
takeTime Velocity
t ( Event a
ev : [Event a]
xs ) =
Event a
ev Event a -> [Event a] -> [Event a]
forall a. a -> [a] -> [a]
: Velocity -> [Event a] -> [Event a]
forall a. Velocity -> [Event a] -> [Event a]
takeTime Velocity
t [Event a]
xs ;
dropTime :: Time -> [Event a] -> [Event a] ;
dropTime :: forall a. Velocity -> [Event a] -> [Event a]
dropTime = (Velocity -> [Event a] -> [Event a])
-> Velocity -> [Event a] -> [Event a]
forall a. (Velocity -> a) -> Velocity -> a
applyStrict Velocity -> [Event a] -> [Event a]
forall a. Velocity -> [Event a] -> [Event a]
dropTimeAux ;
dropTimeAux :: Time -> [Event a] -> [Event a] ;
dropTimeAux :: forall a. Velocity -> [Event a] -> [Event a]
dropTimeAux Velocity
_ [] = [] ;
dropTimeAux Velocity
t ( Wait Velocity
x : [Event a]
xs ) =
Bool -> [Event a] -> [Event a] -> [Event a]
forall a. Bool -> a -> a -> a
ifThenElse (Velocity
tVelocity -> Velocity -> Bool
forall a. Ord a => a -> a -> Bool
<Velocity
x)
( (Velocity -> [Event a] -> [Event a])
-> Velocity -> [Event a] -> [Event a]
forall a. (Velocity -> a) -> Velocity -> a
applyStrict Velocity -> [Event a] -> [Event a]
forall a. Velocity -> [Event a] -> [Event a]
consWait (Velocity
xVelocity -> Velocity -> Velocity
forall a. Num a => a -> a -> a
-Velocity
t) [Event a]
xs )
( (Velocity -> [Event a] -> [Event a])
-> Velocity -> [Event a] -> [Event a]
forall a. (Velocity -> a) -> Velocity -> a
applyStrict Velocity -> [Event a] -> [Event a]
forall a. Velocity -> [Event a] -> [Event a]
dropTimeAux (Velocity
tVelocity -> Velocity -> Velocity
forall a. Num a => a -> a -> a
-Velocity
x) [Event a]
xs ) ;
dropTimeAux Velocity
t ( Event a
_ : [Event a]
xs ) = Velocity -> [Event a] -> [Event a]
forall a. Velocity -> [Event a] -> [Event a]
dropTimeAux Velocity
t [Event a]
xs ;
skipTime :: Time -> [Event a] -> [Event a] ;
skipTime :: forall a. Velocity -> [Event a] -> [Event a]
skipTime = (Velocity -> [Event a] -> [Event a])
-> Velocity -> [Event a] -> [Event a]
forall a. (Velocity -> a) -> Velocity -> a
applyStrict Velocity -> [Event a] -> [Event a]
forall a. Velocity -> [Event a] -> [Event a]
skipTimeAux ;
skipTimeAux :: Time -> [Event a] -> [Event a] ;
skipTimeAux :: forall a. Velocity -> [Event a] -> [Event a]
skipTimeAux Velocity
_ [] = [] ;
skipTimeAux Velocity
t ( Wait Velocity
x : [Event a]
xs ) =
Bool -> [Event a] -> [Event a] -> [Event a]
forall a. Bool -> a -> a -> a
ifThenElse (Velocity
tVelocity -> Velocity -> Bool
forall a. Ord a => a -> a -> Bool
<Velocity
x)
( (Velocity -> [Event a] -> [Event a])
-> Velocity -> [Event a] -> [Event a]
forall a. (Velocity -> a) -> Velocity -> a
applyStrict Velocity -> [Event a] -> [Event a]
forall a. Velocity -> [Event a] -> [Event a]
consWait (Velocity
xVelocity -> Velocity -> Velocity
forall a. Num a => a -> a -> a
-Velocity
t) [Event a]
xs )
( (Velocity -> [Event a] -> [Event a])
-> Velocity -> [Event a] -> [Event a]
forall a. (Velocity -> a) -> Velocity -> a
applyStrict Velocity -> [Event a] -> [Event a]
forall a. Velocity -> [Event a] -> [Event a]
skipTimeAux (Velocity
tVelocity -> Velocity -> Velocity
forall a. Num a => a -> a -> a
-Velocity
x) [Event a]
xs ) ;
skipTimeAux Velocity
t ( Event a
ev : [Event a]
xs ) = Event a
ev Event a -> [Event a] -> [Event a]
forall a. a -> [a] -> [a]
: Velocity -> [Event a] -> [Event a]
forall a. Velocity -> [Event a] -> [Event a]
skipTimeAux Velocity
t [Event a]
xs ;
compressTime :: Integer -> Time -> [Event a] -> [Event a] ;
compressTime :: forall a. Velocity -> Velocity -> [Event a] -> [Event a]
compressTime Velocity
k = (Velocity -> [Event a] -> [Event a])
-> Velocity -> [Event a] -> [Event a]
forall a. (Velocity -> a) -> Velocity -> a
applyStrict ((Velocity -> Velocity -> [Event a] -> [Event a])
-> Velocity -> Velocity -> [Event a] -> [Event a]
forall a. (Velocity -> a) -> Velocity -> a
applyStrict Velocity -> Velocity -> [Event a] -> [Event a]
forall a. Velocity -> Velocity -> [Event a] -> [Event a]
compressTimeAux Velocity
k) ;
compressTimeAux :: Integer -> Time -> [Event a] -> [Event a] ;
compressTimeAux :: forall a. Velocity -> Velocity -> [Event a] -> [Event a]
compressTimeAux Velocity
_k Velocity
_t [] = [] ;
compressTimeAux Velocity
k Velocity
t ( Wait Velocity
x : [Event a]
xs ) =
Bool -> [Event a] -> [Event a] -> [Event a]
forall a. Bool -> a -> a -> a
ifThenElse (Velocity
tVelocity -> Velocity -> Bool
forall a. Ord a => a -> a -> Bool
<Velocity
x)
( (Velocity -> [Event a] -> [Event a])
-> Velocity -> [Event a] -> [Event a]
forall a. (Velocity -> a) -> Velocity -> a
applyStrict Velocity -> [Event a] -> [Event a]
forall a. Velocity -> [Event a] -> [Event a]
consWait (Velocity -> Velocity -> Velocity
forall a. Integral a => a -> a -> a
div Velocity
t Velocity
k Velocity -> Velocity -> Velocity
forall a. Num a => a -> a -> a
+ (Velocity
xVelocity -> Velocity -> Velocity
forall a. Num a => a -> a -> a
-Velocity
t)) [Event a]
xs )
( (Velocity -> [Event a] -> [Event a])
-> Velocity -> [Event a] -> [Event a]
forall a. (Velocity -> a) -> Velocity -> a
applyStrict Velocity -> [Event a] -> [Event a]
forall a. Velocity -> [Event a] -> [Event a]
consWait (Velocity -> Velocity -> Velocity
forall a. Integral a => a -> a -> a
div Velocity
x Velocity
k)
( (Velocity -> [Event a] -> [Event a])
-> Velocity -> [Event a] -> [Event a]
forall a. (Velocity -> a) -> Velocity -> a
applyStrict (Velocity -> Velocity -> [Event a] -> [Event a]
forall a. Velocity -> Velocity -> [Event a] -> [Event a]
compressTimeAux Velocity
k) (Velocity
tVelocity -> Velocity -> Velocity
forall a. Num a => a -> a -> a
-Velocity
x) [Event a]
xs ) ) ;
compressTimeAux Velocity
k Velocity
t ( Event a
ev : [Event a]
xs ) = Event a
ev Event a -> [Event a] -> [Event a]
forall a. a -> [a] -> [a]
: Velocity -> Velocity -> [Event a] -> [Event a]
forall a. Velocity -> Velocity -> [Event a] -> [Event a]
compressTimeAux Velocity
k Velocity
t [Event a]
xs ;
lazyPause :: [Event a] -> [Event a] ;
lazyPause :: forall a. [Event a] -> [Event a]
lazyPause = (Event a -> Bool) -> [Event a] -> [Event a]
forall a. (a -> Bool) -> [a] -> [a]
filter Event a -> Bool
forall a. Event a -> Bool
isWait ;
isWait :: Event a -> Bool ;
isWait :: forall a. Event a -> Bool
isWait (Wait Velocity
_d) = Bool
True ;
isWait Event a
_ = Bool
False ;
duration :: [Event a] -> Time ;
duration :: forall a. [Event a] -> Velocity
duration = Velocity -> [Event a] -> Velocity
forall a. Velocity -> [Event a] -> Velocity
durationAux Velocity
0 ;
durationAux :: Time -> [Event a] -> Time ;
durationAux :: forall a. Velocity -> [Event a] -> Velocity
durationAux Velocity
t ( Wait Velocity
d : [Event a]
xs ) = (Velocity -> [Event a] -> Velocity)
-> Velocity -> [Event a] -> Velocity
forall a. (Velocity -> a) -> Velocity -> a
applyStrict Velocity -> [Event a] -> Velocity
forall a. Velocity -> [Event a] -> Velocity
durationAux (Velocity
tVelocity -> Velocity -> Velocity
forall a. Num a => a -> a -> a
+Velocity
d) [Event a]
xs ;
durationAux Velocity
t ( Event a
_ : [Event a]
xs ) = Velocity -> [Event a] -> Velocity
forall a. Velocity -> [Event a] -> Velocity
durationAux Velocity
t [Event a]
xs ;
durationAux Velocity
t [] = Velocity
t ;
consWait :: Time -> [Event a] -> [Event a] ;
consWait :: forall a. Velocity -> [Event a] -> [Event a]
consWait Velocity
t [Event a]
xs = Velocity -> Event a
forall a. Velocity -> Event a
Wait Velocity
t Event a -> [Event a] -> [Event a]
forall a. a -> [a] -> [a]
: [Event a]
xs ;
infixr 7 +:+ ;
infixr 6 =:= ;
(+:+) :: [Event a] -> [Event a] -> [Event a] ;
[Event a]
xs +:+ :: forall a. [Event a] -> [Event a] -> [Event a]
+:+ [Event a]
ys = [Event a]
xs [Event a] -> [Event a] -> [Event a]
forall a. [a] -> [a] -> [a]
++ [Event a]
ys ;
merge, (=:=) :: [Event a] -> [Event a] -> [Event a] ;
[Event a]
xs =:= :: forall a. [Event a] -> [Event a] -> [Event a]
=:= [Event a]
ys = [Event a] -> [Event a] -> [Event a]
forall a. [Event a] -> [Event a] -> [Event a]
merge [Event a]
xs [Event a]
ys ;
merge :: forall a. [Event a] -> [Event a] -> [Event a]
merge (Wait Velocity
a : [Event a]
xs) (Wait Velocity
b : [Event a]
ys) =
Bool
-> Velocity
-> Velocity
-> [Event a]
-> Velocity
-> [Event a]
-> [Event a]
forall a.
Bool
-> Velocity
-> Velocity
-> [Event a]
-> Velocity
-> [Event a]
-> [Event a]
mergeWait (Velocity
aVelocity -> Velocity -> Bool
forall a. Ord a => a -> a -> Bool
<Velocity
b) (Velocity
aVelocity -> Velocity -> Velocity
forall a. Num a => a -> a -> a
-Velocity
b) Velocity
a [Event a]
xs Velocity
b [Event a]
ys ;
merge (Wait Velocity
a : [Event a]
xs) (Event a
y : [Event a]
ys) =
Event a
y Event a -> [Event a] -> [Event a]
forall a. a -> [a] -> [a]
: [Event a] -> [Event a] -> [Event a]
forall a. [Event a] -> [Event a] -> [Event a]
merge (Velocity -> Event a
forall a. Velocity -> Event a
Wait Velocity
a Event a -> [Event a] -> [Event a]
forall a. a -> [a] -> [a]
: [Event a]
xs) [Event a]
ys ;
merge (Event a
x : [Event a]
xs) [Event a]
ys = Event a
x Event a -> [Event a] -> [Event a]
forall a. a -> [a] -> [a]
: [Event a] -> [Event a] -> [Event a]
forall a. [Event a] -> [Event a] -> [Event a]
merge [Event a]
xs [Event a]
ys ;
merge [] [Event a]
ys = [Event a]
ys ;
mergeWait ::
Bool -> Time ->
Time -> [Event a] ->
Time -> [Event a] ->
[Event a] ;
mergeWait :: forall a.
Bool
-> Velocity
-> Velocity
-> [Event a]
-> Velocity
-> [Event a]
-> [Event a]
mergeWait Bool
_eq Velocity
0 Velocity
a [Event a]
xs Velocity
_b [Event a]
ys =
Velocity -> Event a
forall a. Velocity -> Event a
Wait Velocity
a Event a -> [Event a] -> [Event a]
forall a. a -> [a] -> [a]
: [Event a] -> [Event a] -> [Event a]
forall a. [Event a] -> [Event a] -> [Event a]
merge [Event a]
xs [Event a]
ys ;
mergeWait Bool
True Velocity
d Velocity
a [Event a]
xs Velocity
_b [Event a]
ys =
Velocity -> Event a
forall a. Velocity -> Event a
Wait Velocity
a Event a -> [Event a] -> [Event a]
forall a. a -> [a] -> [a]
: [Event a] -> [Event a] -> [Event a]
forall a. [Event a] -> [Event a] -> [Event a]
merge [Event a]
xs (Velocity -> Event a
forall a. Velocity -> Event a
Wait (Velocity -> Velocity
forall a. Num a => a -> a
negate Velocity
d) Event a -> [Event a] -> [Event a]
forall a. a -> [a] -> [a]
: [Event a]
ys) ;
mergeWait Bool
False Velocity
d Velocity
_a [Event a]
xs Velocity
b [Event a]
ys =
Velocity -> Event a
forall a. Velocity -> Event a
Wait Velocity
b Event a -> [Event a] -> [Event a]
forall a. a -> [a] -> [a]
: [Event a] -> [Event a] -> [Event a]
forall a. [Event a] -> [Event a] -> [Event a]
merge (Velocity -> Event a
forall a. Velocity -> Event a
Wait Velocity
d Event a -> [Event a] -> [Event a]
forall a. a -> [a] -> [a]
: [Event a]
xs) [Event a]
ys ;
mergeMany :: [[Event a]] -> [Event a] ;
mergeMany :: forall a. [[Event a]] -> [Event a]
mergeMany = ([Event a] -> [Event a] -> [Event a])
-> [Event a] -> [[Event a]] -> [Event a]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Event a] -> [Event a] -> [Event a]
forall a. [Event a] -> [Event a] -> [Event a]
merge [] ;